perm filename MUS10.FAI[MUS,LCS]1 blob
sn#309794 filedate 1977-10-12 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00087 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00007 00002 TITLE Music Compiler
C00011 00003 SIZES OF VARIOUS STACKS AND TABLES:
C00014 00004 Bit and Flag Definition
C00020 00005 Macros and Things to Dc
C00023 00006 CONFIG:
C00024 00007 Initializatize the World (START)
C00027 00008 Setup Input Device
C00029 00009 More SETUP
C00032 00010 Initialization of the Compiler.
C00035 00011 ALGOL SCANNER -- 9/8/66 D. POOLE
C00038 00012 Search Tables
C00041 00013 Scan special Characters
C00044 00014 Scan a string constant
C00048 00015 Number Scanner
C00050 00016 Search Number Table
C00052 00017 Reserved word table search, also SCNGET
C00055 00018 SCAN Storage, also PUSHBUCTBL and POPBUCTBL
C00056 00019 CTBL - The character table
C00060 00020 The Reserved word table
C00066 00021 The Main Symbol Table
C00077 00022 Statement Compilation
C00083 00023 Block Statement (BEGIN...END)
C00085 00024 DONE, EXIT, and RETURN
C00088 00025 PRINT Statement
C00091 00026 IF-THEN-ELSE statement
C00096 00027 IF-THEN-ELSE statement - (R-TIME)
C00099 00028 WHILE statement
C00103 00029 UNTIL statement
C00105 00030 FOR Statement
C00112 00031 Recursive Expression Analyzer.
C00117 00032 Primarys
C00123 00033 Compile a Subscript for Array Reference
C00125 00034 Compile a Function Call.
C00131 00035 Code Generators
C00138 00036 Emit code into code buffers
C00142 00037 GPONDER - Examine top element of operand stack
C00147 00038 Array Reference Generation
C00154 00039 GMURK - Set up top two elements of stack for code generation
C00158 00040 GGET - Gets one of top two stack elements into an AC.
C00162 00041 NUMCHK - Compile time arithmetic
C00166 00042 EMINST - Emit an instruction.
C00169 00043 GETAC - Get a free AC.
C00174 00044 Generate Function Calls
C00178 00045 More Code Generator for Function Calls (GFUNC)
C00185 00046 Unit Generator Call
C00194 00047 Enter Item into Symbol Table
C00197 00048 Declarations
C00200 00049 Function declaration
C00205 00050 More Function Declaration
C00210 00051 Instrument Declaration
C00213 00052 Array Definition
C00217 00053 The Loader
C00221 00054 More Loader (But not much more, you will notice!).
C00225 00055 Outer Loop
C00231 00056 PLAY Block Processor (PINS)
C00236 00057 More of PINS
C00241 00058 'PLAYIT' GENERATES SAMPLES BY CALLING THE
C00246 00059 UUOSER - User UUO service
C00250 00060 Error Handling Routines.
C00256 00061 HERE INVOKE RPG!!!
C00259 00062 Illegal array reference routine
C00262 00063 Lookup External in DDT Symbol Table
C00264 00064 Unit Generators
C00270 00065 ZOSCIL Family of Unit Generators
C00275 00066 More generators, LINEN
C00279 00067 Reverberation Unit Generators
C00286 00068 Random Numbers
C00290 00069 FORTRASH Routines and Random Functions
C00294 00070 Extended Commands
C00296 00071 More Command Routines.
C00298 00072 This handy routine tells you what's in the symbol table
C00300 00073 SMPOUT - Sample Output Buffer Routines
C00303 00074 PLINI2: MOVEM F,PLYOPT SAVE PLAY OPTION NUMBER
C00305 00075 EXTERNAL JOBJDA
C00307 00076 Sound file headers
C00314 00077 Routines to Make File Names, and Keep the System Happy
C00319 00078 Sample Output Routines For Each Device
C00322 00079 Sample Buffer Tables, etc.
C00325 00080 SAVER
C00328 00081 Storage Management
C00331 00082 SIXOUT and PRTFLN
C00335 00083 RDBUF - READ A BUFFER
C00337 00084 Numeric Output Routines
C00341 00085 Read number from TTY
C00349 00086 ENTRY WRIOSP ↔ TITLE WRIOSP ↔EXTERNAL WRSIX
C00354 00087 Tables and Flags
C00358 ENDMK
C⊗;
TITLE Music Compiler
SUBTTL Declarations
$BGMUS:
COMMENT ⊗
* * * * * * * * * * * * * * * N O T I C E * * * * * * * * * * * * * * *
If you're going hack it, comment it! (Include your initials in case there's
a bug or incompatability. And remember that conditionals are good for you!)
******** STANFORD, OCT 1977 --- Leland Smith
******** THE ABOVE NOTWITHSTANDING, THIS IS A STRIPPED DOWN VERSION FOR IRCAM.
******** MANY OF THE CONDITIONALS HAVE BEEN REMOVED. THIS VERSION ONLY WRITES
******** ON DSK, AND ALWAYS WITH HEADER BLOCK.
*%*%*%*%*%*%*%* LCS VERSION *%*%*%*%*%*%*%*%*%*
%%%%%% TO LOAD >>>>> LOAD @LCSMUS <<<<<<<<
%%%%%% THEN READ IN 'INIT.LCS' FOR ALL INITIALIZATIONS
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
NOTES AND ABRIV.
C.T. ≡ CHARACTER TABLE
U.G. ≡ UNIT GENERATOR
I-TIME ≡ INITIALIZATION TIME FOR INSTRUMENT
R-TIME ≡ RUN TIME FOR INSTRUMENT
⊗;
INTERNAL RDIOSP,WRIOSP,RDINT,RDSIX,WRINT,POP1J.,POP2J.,POP3J.,POP4J.
;THE FOLLOWING IS TO BE FOUND ON NEWLIB[1,TVR]
;XX EXTERNAL HELPER,RDIOSP,WRIOSP,RDSIX
.LIBRARY TVRLIB.REL[MUS,LCS]
;XX .LIBRARY NEWLIB.REL[1,TVR]
;USEFUL F4 FUNCTIONS TO HAVE AROUND....
EXTERNAL SIN,COS,EXP,ALOG,SQRT,PLAY,SIND
↓THIS←←2
↓SIZ←←3
↓T←1
↓T1←2
↓T2←3 ; (SAME AS INSXR, SEE BELOW)
↓T3←4 ;DO NOT CHANGE, SEE S.QUOTE
↓A←5
↓B←6
↓C←7
↓D←10
↓E←11
↓F←12 ;USED BY COMPILER TO INDICATE R-TIME CODE
↓H←14
↓OSP←13 ;OPERAND STACK POINTER
↓RA←16 ;RETURN ADDRESS FOR FORTRASH
↓P←17 ;PUSH-DOWN LIST POINTER
↓FL←15
;*** Don't change or else everyone who has external unit generators ***
;*** will haved to be re-assembled ***
NACS←←5
NFACS←←4 ;Number of function AC's
↓INSXR←←NFACS-1
;I/O channel allocation
↓TTY←←1
DT←←2
ADCHN←←3
↓SBCHAN←←4
↓SIXCHN←←5
↓DACCHN←←6
↓NOWAIT←←400 ;INHIBIT 'XXX is busy. Will you wait?`
↓WAITBIT←←1000 ;ALWAYS wait!
;SIZES OF VARIOUS STACKS AND TABLES:
↓LOBUFS←←200
LUOTBL←←62 ;LENGTH OF Un LIST
;LPLIST←←100 ;LENGTH OF PUSHDOWN LIST
LPLIST←←200 ;LENGTH OF PUSHDOWN LIST
LOSTK←←40 ;LENGTH OF OPERAND STACK
;LXPLIST←←20 ;LENGTH OF EXTRA PUSHDOWN LIST
LPA←←=50 ;LENGTH OF P_ARRAY
LRQ←←=75 ;LENGTH OF RUN QUEUE.
OPDEF EXP [0]
OPDEF INTJEN [723B8]
OPDEF JRSTF [JRST 2,]
↓UUOTAB←.-1 ;HERE ARE OUR USER UUO'S
↓UUOMAX←0
DEFINE DEFUUO $(NAME)
< ↓UUOMAX←←UUOMAX+1
OPDEF NAME [UUOMAX*1000000000]
.$NAME
>
;*** Don't change (adding OK) or else everyone who has external unit ***
;*** generators will have to re-assembled ***
IFN UUOMAX,
< PRINTS/
Warning: You won't be able to use EXTERNAL UNIT_GENERATOR which call error
routines!!!
/>;IFN UUOMAX
DEFUUO ERRUUO ;Error call (Must be 001000,,0)
DEFUUO TYPCHR ;TYPE A CHARACTER (LIKE OUTCHR)
DEFUUO TYPSTR ;TYPE A STRING (LIKE OUTSTR)
;; DEFUUO BLAST ;SEND MESSAGE TO ANY OF SAME PPN IF NOT AT TTY
OPDEF HALT [HALT] ;SO THAT DDT KNOWS ABOUT THE FOLLOWING
OPDEF TTYUUO[XWD 51000,0]
OPDEF INCHRW[TTYUUO 0,]
OPDEF OUTCHR[TTYUUO 1,]
OPDEF OUTSTR[TTYUUO 3,]
OPDEF INCHWL[TTYUUO 4,]
OPDEF GETLIN[TTYUUO 6,]
OPDEF RESET [CALLI 0]
OPDEF CORE [CALLI 11]
OPDEF EXIT [CALLI 12]
OPDEF DATE [CALLI 14]
OPDEF MSTIME[CALLI 23]
OPDEF GETPPN[CALLI 24]
OPDEF RUNTIM[CALLI 27]
OPDEF SETNAM[CALLI 43] ;DEC SYSTEMS USE A DIFFERENT OPCODE
SUBTTL Bit and Flag Definition
;Character Table bits
MULBIT←←1 ;C.T. '*` OR '/`
ADDBIT←←2 ;C.T. '+` OR '-`
STRFLG←←4 ;DO NOT CHANGE, SEE S.QUOTE
SSPCF ←←10 ;C.T. FLAG
SDFLG ←←20 ;C.T. FLAG
SNUMF ←←40 ;C.T. FLAG
FOOBIT←←100 ;FOO SYMBOL (EITHER P<number> or U<number>)???
FIXFLG←←1000 ;NUMBER TABLE ENTRIES
FLTFLG←←2000
SSPC2F←←4000 ;CHARACTER TABLE ENTRY
RELBIT←←10000 ;RELATIONAL OPERATOR
LOGBIT←←20000 ;C.T. '∧` OR '∨`
DF ←←400000 ;DELIMITER
NUMFLG←←FIXFLG+FLTFLG
;Symbol Table bits
RFLG ←←0 ;$$$%%&%$###""##$%$$$$$
RSTMTB←←20 ;(SYMBOL TABLE) STATEMENT RESERVED WORD
INSBIT←←40 ;INSTRUMENT NAME
GPBIT ←←FOOBIT ;NOT I OR X. (FOO SYMBOL P<number>)
FPARBT←←200 ;FORMAL PARAMETER
DECLBI←←400 ;DECLARACTORY RESERVED WORD
RVBT ←←400 ;R-TIME VARIABLE
PRVBT ←←11 ;SHIFT CONSTANT FOR 'RVBT`
;1000 ;INTEGER
;2000 ;REAL
UGBIT ←←4000 ;U.G. NAME
SRACBT←←10000 ;(STACK) R-TIME AC
SIACBT←←20000 ;(STACK) I-TIME AC
FUNBIT←←40000 ;(IN SYMBOL TABLE) FUNCTION NAME
SUBSBT←←FUNBIT ;(STACK) SUBSRIPT FOR ARRAY
SWVBT ←←100000 ;ARRAY NAME??? (DO NOT CHANGE ! SEE GFUNC.)
ARRYBT←←SWVBT ;NOTE THAT NOT ALL CODE HAS BEEN CONVERTED TO
;USE THIS YET
VRBLBT←←200000 ;VARIABLE
RF ←←DF+RFLG ;RESERVED WORD
; RELOCATION AND FIXUP BITS
.FXBTS←←1
LFXBTS←←2
RRELBT←←4+1 ;R-TIME RELOCATION (LEFT HALF)
IRELBT←←10+1 ;I-TIME RELOCATION (RIGHT HALF)
VRELBT←←14+1 ;VARIABLE RELOCATION (RIGHT HALF)
CHAINB←←20000 ;A CHAIN FIXUP
SWAPBT←←40000 ;SWAPPED FIXUP.
RRFXBT←←100000 ;RIGHT HALF.
LRFXBT←←200000 ;LEFT HALF REPLACEMENT FIXUP BIT.
TWOWRD←←400000 ;TWO WORD FIXUP
; FLAGS (RIGHT HALF):
CSBRBT←←1 ;INSIDE FUNCTION DEFINITION
USBRBT←←2
GFUNCF←←4
SFOOBT←←10 ;LETS SCANNER SEE FOO SYMBOLS
ARRFLG←←20
EXTFLG←←40 ;SET DURING EXTERNAL FUNCTION DEFINITION
RVFLG ←←100
RESTART←←200 ;RESTART FLAG FOR SETUP
INSDEF←←1000 ;INSTRUMENT DEFINITION
; FLAGS (LEFT HALF).
ERRFLG←←1
MINFLG←←2
SNUMF1←←4
NOSTAR←←10 ;DON'T PRINT PRINT PROMPT
DTFLG←←20
PLAYFLG←←40
; AC TABLE FLAGS
ACFLAG ←←SIACBT+SRACBT
;SUBSBT←←40000 ;A SUBSCRIPT (KEEP IN AC)
;SWVBT ←←100000 ;AN ARRAY (SHOULDN'T BE THERE THOUGH)
;VRBLBT←←200000 ;A VARIABLE
NOSWAP ←←400000 ;DON'T SWAP OUT OF AC
; PARAMETER DESCRIPTOR BITS:
;*** Don't change (adding OK) or else everyone who has external unit ***
;*** generators will have to re-assembled ***
↓ARRPAR←←1 ;ARRAY PARAMETER
↓VARPAR←←2 ;REAL PARAMETER
↓ZTMPPAR←←4 ;ZEROED TEMPORARY
↓TMPPAR←←5 ;TEMPORARY
↓STRPAR←←6 ;STRING PARAMETER
↓INTPAR←←11 ;INTEGER PARAMETER
↓STAPAR←←12 ;ARRAY OR STRING PARAMETER
BITABL: ;There is a feature in our debugger to print bit symbols
RADIX50 0,DF ;400000 ;DELIMITER
RADIX50 0,VRBLBT ;200000 ;VARIABLE
RADIX50 0,SWVBT ;100000 ;ARRAY NAME???
RADIX50 0,FUNBIT ;40000 ;(IN SYMBOL TABLE) FUNCTION NAME
RADIX50 0,SIACBT ;20000 ;(STACK) I-TIME AC
RADIX50 0,SRACBT ;10000 ;(STACK) R-TIME AC
RADIX50 0,UGBIT ;4000 ;U.G. NAME
RADIX50 0,FLTFLG ;2000
RADIX50 0,FIXFLG ;1000 ;NUMBER TABLE ENTRIES
RADIX50 0,DECLBI ;400 ;DECLARACTORY RESERVED WORD
RADIX50 0,FPARBT ;200 ;FORMAL PARAMETER
RADIX50 0,FOOBIT ;100 ;FOO SYMBOL
RADIX50 0,INSBIT ;40 ;INSTRUMENT NAME
RADIX50 0,RSTMTB ;20 ;(SYMBOL TABLE) STATEMENT RESERVED WORD
RADIX50 0,SSPCF ;10 ;C.T. FLAG
RADIX50 0,STRFLG ;4 ;Strings
RADIX50 0,ADDBIT ;2 ;C.T. '+` OR '-`
RADIX50 0,MULBIT ;1 ;C.T. '*` OR '/`
BLOCK =18
SUBTTL Macros and Things to Dc
COMMENT ⊗ THINGS TO DO
MAKE NEW PARAMETER DESCRIPTOR
Change PUSHJ P,ILLARF to something less dangerous!!!
Fix SETDATE in SMPOUT to know about DATE75
⊗;
DEFINE ILG
< XWD DF+SSPCF,SILCH
> ;ILLEGAL CHARACTER MARKER FOR SYMBOL TABLE
; ERROR AND DEBUGGING MACROS
DEFINE ERROR (M) ;FATAL ERROR
< ERRUUO 1,[ASCIZ /M/]
>
DEFINE WARN (M) ;WARNING
< ERRUUO 2,[ASCIZ /M/]
>
DEFINE SKWARN (M) ;WARNING, SKIPS IF NOT A WARNING
< ERRUUO 3,[ASCIZ /M/]
CAIA
>
DEFINE WARNSK (M) ;WARNING, SKIPS AFTER CONTINUE
< ERRUUO 3,[ASCIZ /M/]
>
;USED WHEN SOMETHING HAPPENS THAT SHOULDN'T LIKE NOT BEING ABLE TO INIT DSK
DEFINE SYSERR (M)
< ERRUUO 4,[ASCIZ /M/]
>
DEFINE DEBUG (M)
< SKIPE DEBUGF
ERRUUO 10,[ASCIZ/M/]
>
DEFINE DEBUG2 (M) ;THIS FLAVOR STOPS IF IN MODE 4
< SKIPE DEBUGF
ERRUUO 11,[ASCIZ/M/]
>
DEFINE COREFULL ;WE RAN OUT OF CORE, LET TRY TO GET SOME MORE
< PUSHJ P,.CORFL ;SKIP IF NOT CALLED
SKIPA
>
;CONCATONATE TWO SYMBOLS
DEFINE CAT &(SYM1,SYM2)
<SYM1&SYM2>
;Macro to handle the two flavours of FIX instructions/UUOs
;outside of Stanford. This mess is because there wasnit enough
;space left in the KL10 microcode space and the FIX instruction
;which was on the KA10 was not implemented in the KL10. Because
;of this, FAIL at Stanford had the opcode for FIX changed to
;KAFIX and the opcode for the KI10 FIX instruction (which is an
;inferior instruction) introduced as KIFIX.
CONFIG:
ASCIZ/Stanford Music Compiler -- LCS Version /
PRINTS/Stanford Music Compiler -- LCS Version
/
SUBTTL Initializatize the World (START)
START:
GO: MOVE P,PDLIOWD
;Distinguish between KA10 and KL10
SETZ 0, ;BLT works different on KL10 from KA10
BLT 0,0 ;On KL10, will set 0 to 1,,1 and then
;copy itself to itself. On KA10, it
;will copy 0 to 0
JUMPE 0,[OUTSTR[ASCIZ/?
This program only runs on the KL10. Sorry.
(Please type 'R NEWMUS' instead)/]
EXIT]
KALUSER:
AOSLE ONCEFG ;IS THIS FIRST TIME THROUGH ?
JRST GOA ;NO. LEAVE JOBFF AT CURRENT PLACE.
OUTSTR CONFIG ;Print version number
GO1: MOVEI 0,GOB ;SET REEENTER ADR.
MOVEM JOBREN↑
HLRO 1,JOBSYM↑ ;YES. GET BEGINNING OF SYM. TAB. FROM JOBSYM
MOVNS 1
ADD 1,JOBSYM ;ADD LENGTH OF SYM. TAB.
HLRZ 0,JOBSA↑
CAIL 0,(1)
MOVE 1,0
AOSN ONCEFG ;WAS THIS A FROZEN COPY?
HRRZM 1,JOBFF ;NO, RESET JOBFF *****
MOVE JOBFF
MOVEM OLDJFF# ;SAVE PRESENT JOBFF
MOVE [XWD SVAREA,BUCTBL]
BLT SVAREA-1
GOA: HRRZ JOBFF ;*****
HRLM JOBSA
MOVEI FL,0
PUSHJ P,SETUP
GOB: MOVE P,PDLIOWD
REPEAT 0,< ;Moved to after SCHOWN
MOVE JOBREL
MOVEM BEGFREE ;*****
SUB JOBFF
SKIPN GETMORE# ;DO WE NEED TO GET MORE?
CAIGE =2048 ;NO, DO WE HAVE AT LEAST 2K WORDS OF CORE?
COREFULL ;COREFULL WILL KINDLY GET US SOME MORE
SETZM GETMORE ;CLEAR CORE REQUEST FLAG
>;REPEAT 0
JRST SCHOWN ;YES, RETURN
ONCEFG: -2 ;-1 FOR FROZEN COPIES
DEBUGF: 0
LSTFUL: 0
SUBTTL Setup Input Device
;INPUT ROUTINE. CALL INITIALLY WITH PUSHJ P,SETUP
;WILL READIN DTA# AND FILE NAME. GET CHRS BY
;ILDB IBUF+1. NEXT BUFFER BY INPUT DT,0.
SETUP: RESET
MOVE [JSR UUOSER]
MOVEM 41 ;SET UP UUO TRAP
SETZM INERR
SETZM INUUO
;;; MOVEI INTSER
;;; MOVEM JOBAPR↑
;;; MOVE INTBIT
;;; INTENB
SETUP1: INIT TTY,1
SIXBIT /TTY/
XWD TOB,TIB
SYSERR <Can't INIT TTY!>
COMMENT ⊗ An unlikely situation. ⊗;
MOVSI 400000
ANDCAM TIBUF+1 ;MARK INPUT BUFFERS EMPTY.
ANDCAM BUF1+1
ANDCAM BUF2+1
ANDCAM BUF3+1
HRRI TIBUF+1 ;INIT. BUFFER POINTERS.
MOVEM TIB
HRRI TOBUF+1
MOVEM TOB
OUTPUT TTY, ;SEE THE HAPPY SYSTEM
TRNE FL,RESTART ;ARE WE RESTARTINIG ?
JRST SETUP2 ; Yes
OUTSTR [ASCIZ /
INPUT ? /]
PUSH P,[DNAM]
PUSH P,[INCHWL 1]
PUSH P,[0]
PUSHJ P,RDIOSP
JRST [ MOVSI 1,'TTY'
MOVEM 1,DNAM
JRST .+1 ]
PUSHJ P,IGNOLF
JRST SETUP2
BUF1: 0
XWD 201,BUF2+1
BLOCK 202
BUF2: 0
XWD 201,BUF3+1
BLOCK 202
BUF3: 0
XWD 201,BUF1+1
BLOCK 202
; More SETUP
TIB: 0
POINT 7,0,35
0
TOB: 0
POINT 7,0,35
0
TIBUF: 0
XWD 21,.
BLOCK 22
TOBUF: 0
XWD 21,.
BLOCK 22
1 ;MODE
DNAM: 0
XWD 0,IBUF
DLK: BLOCK 5
RECCT: 0
IBUF: XWD 400000,BUF1+1; MAGIC TO KEEP SYSTEM
SCP: POINT 7,0,35; HAPPY
ICCNT: 0 ;BUFFER CHAR. COUNT.
SETUP2: OPEN DT,DNAM-1
JRST AER1
MOVE [XWD 400000,BUF1+1] ;SET UP BUFFER
MOVEM IBUF ;HEADER SO SYSTEM WILL USE OUR BUFFERS.
MOVSI 700
MOVEM SCP ;BYTE SIZE.
TRZE FL,RESTART ;ARE WE RETARTING
JRST SETIN ;YES, SKIP REST
MOVEI T,1 ;SET INFO FOR EDITTING
MOVEM T,LINCNT
MOVEM T,PAGCNT
SETZM LINENO
MOVEM T,RECCT
;;;SETIN: MOVE T,DLK+3 ;SAVE P,PN OVER LOOKUP
SETIN: SETZM DLK+3 ; ZERO PPN
LOOKUP DT,DLK
JRST [ MOVSI 'MUS' ;Assume 'MUS' as default extension
EXCH DLK+1
TLNN -1 ;Make sure extension was't given
LOOKUP DT,DLK
JRST NER1 ;NON-EX FILE
JRST .+1 ]
;;; MOVEM T,DLK+3 ;RESTORE P,PN
PUSHJ P,RDBUF ;GET FIRST BUFFER
MOVE BUF1+3 ;LINE NO. FIRST ?
TRNE 1
AOS SCP ;YES; ADVANCE SCP PAST IT.
SETZM SNCHR
SETZM FOONLY# ;BARF !!
POPJ P,; DONE
; Error routines for SETUP
AER1: TYPSTR [ASCIZ /
Device: /] ;ERROR ROUTINE FOR DEVICE NOT AVAILABLE
MOVEI T1,4
MOVEI DNAM
PUSHJ P,SIXOUT
TYPSTR [ASCIZ / not available.
/]
JRST SETUP
NER1: EXCH 0,DLK+1 ;Get back old extension
NER: TYPSTR [ASCIZ /
File: /] ;ERROR ROUTINE FOR FILE NOT FOUND
PUSH P,[DLK]
PUSHJ P,PRTFLN
NEX1: TYPSTR [ASCIZ / not found.
/]
JRST SETUP
SUBTTL Initialization of the Compiler.
EXTERNAL JOBFF,JOBSA
BEGFREE: 0 ;POINTER TO BEGINNING OF FREE STORAGE AREA
SCOMPA: MOVE OSP,[IOWD LOSTK,OSTK] ;INIT. OPERAND STACK.
PUSH OSP,BEGFREE ;...SO WE CAN RESTORE IT LATER.
MOVSI IRELBT ;INIT THE THREE LOCATION
MOVEM ILOC ;COUNTERS (APPROPRIATE RELOCATION
MOVSI RRELBT ;BITS LIVE IN LEFT HALF OF EACH).
MOVEM RLOC
MOVSI VRELBT
MOVEM VLOC
MOVEI T1,2 ;SET UP THE THREE CHAINS OF OUTPUT
SCMP1: SETZM OBPTR(T1)
PUSHJ P,GBUF ;BUFFERS.
HRRZM T,FCBUF(T1) ;PTR. TO FIRST BUFFER OF CHAIN
SOJGE T1,SCMP1 ;DO FOR ALL THREE CHAINS.
SETZM IARR1 ;ZERO SOME TABLES AND STUFF.
MOVE [XWD IARR1,IARR1+1]
BLT IARR2-1
SETOM IARR1 ;SET THESE TO -1
MOVE [XWD IARR2,IARR2+1]
BLT IARR5-1
MOVEI FL,0 ;CLEAR FLAGS.
POPJ P,
SCOMP: PUSHJ P,SCOMPA ;INIT. THE COMPILER.
SETZM IARR4
MOVE [XWD IARR4,IARR4+1]
BLT IARR3-1 ;ZERO REST OF TABLES.
POPJ P,
;DONE WITH COMPILATION, CLEAN UP YE OLE COMPILER
ENDP1:
SKIPE BLEVEL ;ARE ALL BLOCKS CLOSED
WARN <Missing END> ;NO!
COMMENT ⊗ FINISH statement giving inside a block. ⊗;
MOVEI A,0
MOVEI B,.FXBTS ;PUT END MARKS IN THE BUFFERS.
PUSHJ P,EMCD
PUSHJ P,EMICD
PUSHJ P,EMVCD
; POP OSP,BEGFREE ;RESTORE BEGFREE.
;WHY DID YOU RELEASE FREE STORAGE BEFORE YOU WERE DONE WITH, D.POOLE?!!?
POPJ P,
SUBTTL ALGOL SCANNER -- 9/8/66 D. POOLE
;CALL IS PUSHJ P,-----. SCANS NEXT ATOMIC ELEMENT OF
; INPUT STRING, RETURNS ELEMENT IN ACCUM. 'A' AS FOLLOWS:
; UNDEFINED IDENTIFIER-- RETURNS 0.
; DECLARED IDENTIFIER--- 'A' CONTAINS RANDOM GOOD BITS FROM
; THE SYM. TBL. IN LEFT HALF, PTR. TO RGB WORD IN RT. HALF.
;RESERVED WORD OR SINGLE-CHARACTER OPERATOR--- 'A' CONTAINS
; THE RANDOM BITS WORD FROM EITHER THE RESERVED WORD TABLE
; OR THE CHAR. CONVERT TABLE, RESPECTIVELY.
BEGIN SCAN
↑BUCKNO←←1; SEE DFUNC BEFORE CHANGING !!!!
↑ACCUM: BLOCK 40 ;GOOD ENOUGH FOR NOW...
ACCEND←←.
↑SCANNS: TLOA FL,NOSTAR ;SUPRESS PRINTING OF *.
↑SCANR: TLOA FL,400000 ;ENTRY WHEN EXPECTING OPERATOR OR
; RESERVED WORD.
↑SCANV: TLZ FL,400000 ;ENTRY WHEN EXPECTING VARIABLE.
↑SCAN:
SKIPE A,SNCHR ;IF SNCHR IS NON-ZERO,
JRST SL1 ; IT IS THE NEXT CHAR. TO SCAN.
SL10: ILDB A,SCP ;GET NEXT CHAR.
SKIPN A,CTBL(A) ;SKIP LEADING BLANKS.
JRST SL10
JUMPL A,SL1B ;IF OPERATOR, WE'RE DONE.
TLNE A,SNUMF ;CHECK FOR PART OF A NUMBER.
JRST SNUM1
MOVE T2,[POINT 6,ACCUM,5] ;PREPARE TO SCAN AN
SETZB T,ACCUM ;IDENTIFIER.
MOVEM T,ACCUM+1
MOVEM A,FOONLY
SL2: IDPB A,T2 ;APPEND CHAR. TO IDENTIFIER.
SL2A: ILDB A,SCP ;NEXT CHAR.
SKIPLE A,CTBL(A) ;CHECK FOR TERMINATOR.
AOJA T,SL2 ;INCREMENT COUNT AND LOOP.
TLNE A,SSPC2F ;DOES TERMINATING CHAR. REQUIRE IMMEDIATE
;ATTENTION?
JRST [ PUSHJ P,(A) ;YES!
JRST SL2A]
MOVEM A,SNCHR ;NO, SAVE IT FOR NEXT TIME.
ADDI T,1
DPB T,[POINT 6,ACCUM,5] ;PUT COUNT IN FIRST CHAR.
SETZ A,
TLNN T2,770000 ;HAVE WE FILLED THE LAST CHARACTER IN WORD?
JRST .+3 ;YES
IDPB A,T2 ;NO, PUT IN A 0
JRST .-3 ;TRY AGAIN
HRRZS T2
SUBI T2,ACCUM
HRRZM T2,ACCWC#
; Search Tables
MOVE A,ACCUM ;PREPARE TO SEARCH TABLES.
MOVE C,ACCUM+1
TLZE FL,400000 ;DO WE EXPECT AN OPERATOR ?
JRST SRSCH ;YES; SEARCH RES. WD. TBL. FIRST
SMSCH: MOVE T,A ;SEARCH MAIN SYM. TBL.
IDIVI T,BUCKNO ;DO HASH ON IDENT.
MOVMS T1 ;MAKE SURE IT'S POSITIVE.
MOVEM T1,CBNO ;SAVE BUCKET NO.
HRRZ B,BUCTBL(T1) ;HEAD OF RIGHT BUCKET IN SYM. TBL.
SL5: CAMN A,1(B) ;COMPARE FIRST WORDS.
JRST SL4
SL6: HRRZ B,(B) ;GET NEXT ELEMENT OF
JRST SL5 ; THE LINKED LIST.
SL4: CAIN B,A-1 ;FIRST WORD WAS EQUAL...
JRST SNO ; WE ARE AT END OF BUCKET.
SKIPN T1,T2
JRST SFOUND ;ONLY 1 WORD; WE'RE DONE.
CAME C,3(B) ;COMPARE SECOND WORDS...
JRST SL6 ;NOPE.
SOJE T1,SFOUND ;ANY MORE WORDS ?
MOVE T3,[XWD B,4]; YES. PREPARE TO CHECK THEM.
SL7: MOVE D,ACCUM-2(T3)
CAME D,@T3
JRST SL6 ;NOT EQUAL.
SOJE T1,SFOUND ;MORE STILL ?
AOJA T3,SL7 ;YES; KEEP CHECKING.
SFOUND: MOVEI A,2(B) ;FOUND HIM; CALC. PTR. TO RGB WORD.
HLL A,(A) ;GET RANDOM GOOD BITS.
HRRZ B,A
SEXIT: CAIG T2,1 ;MORE THAN 2 WORDS OF NAME ?
POPJ P, ;NO.
SETZM ACCUM(T2) ;YES; ZERO OUT ALL THE WORDS OF
SOJA T2,SEXIT ; ACCUM THAT WE USED.
SNO: TLCN FL,400000 ;NOT IN MAIN TBL; HAVE WE ALREADY
JRST SRSCH ; SEARCHED RES. WORD TBL ?
SN1: MOVE A,FOONLY ;GARPBAZ !
TLNE A,FOOBIT
JRST FOOSCH
SCH1: SETZB A,B ;YES. RETURN 'UNDEFINED'.
POPJ P,
SL1: SETZM SNCHR ;RETURN FOR A SPECIAL CHAR.
SL1A: TLNE A,SSPC2F ;DID IT REQUIRE IMMEDIATE SERVICE?
PUSHJ P,DRYROT ;IT DIDN'T GET IT!!
SL1B: TLNN A,SSPCF+SSPC2F ;DOES IT NEED SPECIAL ATTENTION?
POPJ P,
PUSHJ P,(A) ;YES. DISPATCH ON IT.
JRST SL10 ;CONTINUE SCANNING.
; Scan special Characters
FOOSCH: LDB B,[POINT 6,ACCUM,17]
TRNE FL,SFOOBT ;ARE WE DEFINING A FUNCTION ?
JRST SCH1 ;YES. NO FOO-SYMBOLS ALLOWED.
CAIG B,31 ;IS IT A DIGIT?
CAIGE B,20
JRST SCH1 ;NO.
SUBI B,20 ; TO VALUE.
LDB C,[POINT 6,ACCUM,23]
JUMPE C,FSCH1
LDB D,[POINT 6,ACCUM,29]
JUMPN D,SCH1
IMULI B,12 ;MUL. TENS DIGIT BY 10.
CAIG C,31
CAIGE C,20
JRST SCH1
ADDI B,-20(C) ;ADD IN ONE'S DIGIT.
FSCH1: DPB B,[POINT 17,A,35] ;PUT NUMBER IN A.
POPJ P, ;RETURN FROM SCAN.
↑S.NULL: JRST SENDL
↑S.FF: SETZM LINCNT ;FORM FEED, RESET LINE COUNT AND INCREMENT PAGE COUNT
AOS PAGCNT
↑S.LF: AOS LINCNT ;LINE FEED, INCREMENT LINE COUNT
MOVE A,NXTPAG
JUMPE A,S.VT ;FAST EXIT FOR NO DEBUG MODE
CAMLE A,PAGCNT ;ARE WE AT THE RIGHT PAGE?
JRST S.VT ;NO
MOVE A,NXTLIN
JUMPE A,S.VT ;FAST EXIT FOR NO DEBUG MODE
CAMLE A,LINCNT ;ARE WE UP TO RIGHT LINE
JRST S.VT ;NO
SETZM NXTPAG
SETZM NXTLIN
MOVEI A,2 ;SET DEBUGFLAG TO 2 (STOP EVERYTIME)
MOVEM A,DEBUGF
DEBUG <AT OR PAST REQUESTED LINE>
↑S.VT: ;VERTICAL TAB.
↑SENDL: PUSH P,T ;SAVE T AS IT IS NEEDED
TLZ FL,ERRFLG ;END OF LINE. CLEAR ERROR FLAG.
MOVE A,SCP ;GET PTR TO WORD.
SKIPN T,(A) ;CHECK THIS WORD
JRST S.EOB ;ZERO WORD MEANS END OF BUFFER.
ADDI A,1
MOVE T,(A)
TRNN T,1 ;IS IT A LINE NO. ?
JRST POPTJ ;NO; CONTINUE SCANNING.
MOVEM T,LINENO
TLZ A,770000 ;YES; ADVANCE PTR. PAST IT.
MOVEM A,SCP
↑POPTJ: POP P,T ;RESTORE T
POPJ P, ;RETURN
↑S.EOB: PUSHJ P,RDBUF ;REFILL BUFFER.
JRST SENDL+1
SSPCB: ;HALT
SSPCC: ;HALT
PUSHJ P,DRYROT
↑S.LT: SKIPE LOGFLG ;DO WE SEE '<` AS COMMENTER?
JRST [ MOVE A,[XWD DF+RELBIT,LOP];NO, GET REAL CONTENT
POP P,(P) ;THROW TOP OF P
POPJ P,] ;RETURN
MOVE B,LFV
PUSHJ P,.COMM2
JRST S.LF
;Scan a colon and check for ':='
↑S.COLN:popj p,
; Scan a string constant
;
↑S.QUOT: SETZM SNCHR ;IS THIS NECESSARY?
MOVE T2,[POINT 7,ACCUM] ;GET A BYTE POINTER FOR STRING
MOVSI T,-5*(ACCEND-ACCUM) ;AND HOW MANY CHARACTERS WE CAN FIT
S.QUO2: ILDB A,SCP ;GET A CHARACTER
CAIN A,42 ;IS IT AN END OF STRING (A SECOND '"`)
JRST S.QUO4 ;YES
JUMPE A,S.QUO3 ;DON'T PUT NULL INTO STRINGS!!!
CAIN A,"≡" ;IS IT A MAGIC QUOTE CHARACTER?
ILDB A,SCP ;YES, GET ANY CHARACTER
AOBJP T,[ERROR <String too long or missing ">]
COMMENT ⊗ Strings have a limited length. ⊗;
IDPB A,T2 ;PUT IT INTO ACCUM
CAIE A,"<" ;%$%$%%&#! DON'T GET ITS CHARACTER TABLE ENTRY
S.QUO3: MOVE A,CTBL(A) ;GET IT'S TABLE ENTRY
TLNE A,SSPCF+SSPC2F ;DOES IT REQUIRE SERVICE
CAMN A,[ILG] ;BUT ISN'T ILLEGAL CHARACTER
JRST S.QUO2 ;NO, GO GET ANOTHER
PUSHJ P,(A) ;DISPATCH ON ANYTHING ELSE
JRST S.QUO2 ;GO GET ANOTHER
S.QUO4: SETZ A, ;CLOSING QUOTE FOUND
AOBJP T,[ERROR <String too long or missing ">]
COMMENT ⊗ Strings have a limited length. ⊗;
IDPB A,T2 ;MAKE SURE THERE IS AT LEAST ONE NULL BYTE
TLNE T2,760000 ;IS THE WORD FILLED WITH ZEROS YET?
JRST .-3 ;NO
SUBI T2,ACCUM ;CALCULATE WORD COUNT
ADDI T2,1
HRRZM T2,ACCWC ;SAVE WORD COUNT
MOVE T3,(P) ;PUT IT SOMEWHERE SAFE (WE DON'T NEED OUR
;RETURN ADDRESS ANYMORE ANYWAY)
MOVE A,[XWD STRFLG,STRBUC+1] ;GET FIRST NODE
;**** NOTE THAT STRFLG=T3 AND IS USED AS AN INDEX
;REGISTER DURING STRING COMPARE!
STRSRH: HRR A,-1(A) ;LOOK AT NEXT NODE
TRNN A,777760 ;AT END?
JRST STRNFD ;YES, STRING NOT FOUND, ENTER IT
SETZ T3, ;LET'S SEE IF IT'S WHAT WE'RE LOOKING FOR
STRSR2: MOVE T,ACCUM(T3)
CAME T,@A ;'A` CONTAINS <node address>(T3)
JRST STRSRH ;NOP, TRY THE NEXT NODE
TRNE T,376 ;IS IT THE END OF THE STRING?
AOJA T3,STRSR2 ;NO, LOOK AT THE NEXT WORD
JRST STRFIN
STRNFD: MOVE T,ACCWC ;GET SIZE OF STRING
ADDI T,1 ;FOR THE LINK
PUSHJ P,GPS ;GET SOMEWHERE TO PUT IT
AOS T2,T
HRLI T2,ACCUM ;MAKE A BLT POINTER
HRR A,T ;TO RETURN FROM SCAN
ADD T,ACCWC ;AND FIND OUT ADDRESS OF LAST WORD
; BLT T2,(T) ;COPY IT (gee! that never should have worked)
BLT T2,-1(T) ;COPY IT
HRRZ T2,A
EXCH T2,STRBUC ;GET LAST POINTER AND MAKE THIS NEW POINTER
MOVEM T2,-1(A) ;PUT INTO LINK
STRFIN: POP P,T3 ;RESTORE T3
POPJ P, ;AND WE'RE DONE
; Number Scanner
SNUM1: MOVEI C,0 ;NUMBER SCANNER.
CAMN A,DOTV ;FIRST THING A DECIMAL PT.?
JRST SNUM6 ;YES
MOVNI T,100 ;NO DEC PT. YET.
SNUM2: IMULI C,12
ADDI C,-20(A) ;CONVERT NEW DIGIT TO VALUE AND ADD IN
AOSA T ;INCREMENT DEC. PLACE COUNT.
SNUM6: MOVEI T,0 ;START COUNTING DEC. PLACES.
ILDB A,SCP ;NEXT CHAR.
SKIPG A,CTBL(A) ;GET MAGIC BITS.
JRST SNUM7 ;IT'S A DELIMITER.
TLNE A,SDFLG ;IS IT A DIGIT ?
JRST SNUM2 ;YES.
CAMN A,DOTV ;A DEC. PT. ?
JRST SNUM6 ;YES.
JRST SNUMX1
SNUM7: TLNE A,SSPC2F ;DOES DELIM. REQUIRE INSTANT SERVICE ?
JRST [ PUSHJ P,(A) ;SERVICE IT AND TRY AGAIN
JRST SNUM6+1]
MOVEM A,SNCHR ;SAVE FOR NEXT TIME.
; JUMPLE T,SNFX ;IF NO DEC. PT. SEEN, IT'S FIXED PT.
SFLTIT: IDIVI C,400000 ;FLOAT IT.
SKIPE C
TLC C,254000
TLC D,233000
FAD C,D
SKIPLE T
FDVR C,[10.0] ;DIVIDE BY 10 ENOUGH TO GET
SOJG T,.-1 ;DEC. PT. IN RIGHT PLACE.
SKIPA T,[XWD FLTFLG,0] ;GET FLOATING PT. FLAG.
SNFX: MOVSI T,FIXFLG
HLLZ A,T ;COPY FLAG TO A.
TRNN FL,SFOOBT
TLZE FL,SNUMF1 ;SKIP IF WE'RE SAVING NUMBERS TODAY
POPJ P,
; Search Number Table
↑SRHNUM: TDOA A,NUMBUC ;NUMBUC TO RT. HALF.
SNUM4: HRR A,-1(A) ;GET NEXT LINK.
CAME C,(A) ;IS IT EQUAL ?
JRST .-2 ;NO.
TRNN A,777760 ;ARE WE AT END OF TABLE ?
JRST SNUMNO ;YES.
TDNN T,-1(A) ;NO. DO TYPES MATCH ?
JRST SNUM4 ;NO.
POPJ P, ;YUP. WE'VE FOUND IT.
SNUMNO: ;TRNE FL,CSBRBT ;ARE WE INSIDE A FUNCTION DEFINITION ?
; JRST SNUMX ;YES.
;WHY IS IT NECESSARY TO TREAT FUNCTION DEFINTIONS SPECIAL???!!?
MOVEI T,2 ;INSERT NUMBER INTO TABLE
PUSHJ P,GPS ;GET SOME PERMANENT STORAGE
AOS T
HRR A,T
EXCH T,NUMBUC ;UPDATE NUMBUC.
HRRM T,-1(A) ;PUT IN NEW LINK.
HLLM A,-1(A) ;PUT IN TYPE FLAG.
MOVEM C,(A) ;ALSO VALUE.
POPJ P,
COMMENT ⊗ DISCONNECTED!
SNUMX: IOR T,VLOC ;WE WILL PUT NO. IN VARIABLES AREA.
PUSH P,T ;SAVE PTR. TO LOC.
MOVE A,C ;VALUE OF NO. TO A.
MOVEI B,0 ;NO RELOCATION.
PUSHJ P,EMVCDI ;EMIT TO VARIABLES BUFFER.
JRST POPAJ ;SEE EMINST.
⊗;
; Reserved word table search, also SCNGET
SRSCH: LDB B,[POINT 6,ACCUM,5] ;GET CHAR. COUNT.
CAIL B,2 ;NO 1-CHAR. RES. WDS.
CAILE B,MAXRSZ ;ALSO NONE OF > 9 CHARS.
JRST SRNO
MOVE B,SRTBL1-2(B) ;GET RIGHT SECTION OF TBL.
CAME A,(B) ;COMPARE FIRST WORD.
SRS1: AOBJN B,.-1
JUMPGE B,SRNO ;ARE WE AT END OF SECTION ?
CAME C,LRTBL(B) ;NO; COMPARE SECOND WORD.
JRST SRS1
MOVE A,GRTBL(B) ;THIS IS IT; GET GOOD BITS.
TLNE A,SSPCF ;DOES IT NEED OUR ATTENTION ?
JRST (A) ;YES.
JRST SEXIT ;NO.
SRNO: TLCN FL,400000 ;NOT A RES. WORD; HAVE WE ALREADY
JRST SMSCH ;SEARCHED MAIN SYM. TBL. ?
JRST SN1 ; YES; RETURN.
↑.COMME: MOVE A,SNCHR ;A COMMENT; SKIP TO NEXT ';'
SETZM SNCHR
MOVE B,SEMICV
PUSHJ P,.COMM1
JRST SCAN
.COMM1: CAMN A,B ;DID WE FIND THE CHARACTER WE WERE LOOKING FOR?
POPJ P, ;YES, RETURN
CAME A,[ILG] ;IGNORE ILLEGAL CHARACTERS
CAMN A,QUOTEV ;DON'T PARSE STRINGS!!!!!
JRST .COMM2
CAMN A,LTV ;DON'T ACT ON '<'
JRST .COMM2
TLNE A,SSPCF+SSPC2F ;SPECIAL TREATMENT ?
PUSHJ P,(A) ;YES.
.COMM2: ILDB A,SCP
MOVE A,CTBL(A)
JRST .COMM1
;Character stream for scan
↑SCNGET:PUSH P,A ;SAVE A
ILDB 1,SCP
MOVE A,CTBL(1)
TLNN A,SSPCF+SSPC2F ;SPECIAL?
JRST SCNGE3 ;NO, RETURN
JUMPE 1,SCNGE2
CAIL 1,12 ;We only want to think about non-printing characters
CAILE 1,15 ;here
JRST SCNGE3
SCNGE2: PUSHJ P,(A) ;Call appropriate routine (better not step in 1!!!)
SCNGE3: POP P,A
POPJ P,
;SCAN Storage, also PUSHBUCTBL and POPBUCTBL
↑CBNO: 0
↑SNCHR: 0
↑PUSHBUCTBL: 0
IFL BUCKNO-6
<FOR I←1,BUCKNO,1
< PUSH P,BUCTBL+I-1
>>
IFGE BUCKNO-6
< MOVE P
HRLI BUCTBL
BLT BUCTBL-1(P)
ADD P,[XWD BUCKNO,BUCKNO]
>
JRST @PUSHBUCTBL
↑POPBUCTBL: 0
IFL BUCKNO-6
<FOR I←1,BUCKNO,1
< POP P,BUCTBL+BUCKNO-I
>>
IFGE BUCKNO-6
< POP P,BUCTBL-1(P)
HRLI BUCTBL
BLT BUCTBL+BUCKNO-1
SUB P,[XWD BUCKNO,BUCKNO]
>
JRST @POPBUCTBL
BEND SCAN
;Initialize symbol table pointers
FOR I←0,BUCKNO-1,1
< .TMP2←I
CAT(SYM,→.TMP2)←←A-1
>
SUBTTL CTBL - The character table
;GOOD BITS FOR EVERYONE ! --- GET YOURS WHILE THEY LAST !
BEGIN CHRTAB
XALL ;TURN OFF MACRO EXPANSION
↑CTBL: XWD DF+SSPC2F,S.NULL ; NULL
REPEAT 3,<ILG> ; ↓ α β
↑ANDV: XWD DF+LOGBIT,ANDOP ; ∧
↑NOTV: ILG ; ¬
ILG ; ε
ILG ; π
ILG ; λ
0 ; HORIZONTAL TAB.
↑LFV: XWD DF+SSPCF,S.LF ; LINE FEED
XWD DF+SSPCF,S.VT ; VERTICAL TAB
XWD DF+SSPCF,S.FF ; FORM FEED
0 ; CARRIAGE RETURN.
ILG ; ∞
ILG ; ∂
XWD RF+RSTMTBT,CBLOCK ; ⊂ (EQUIVALENT TO RESERVED WORD BEGIN)
XWD RF,ENDV ; ⊃ (EQUIVALENT TO RESERVED WORD END)
ILG ; ∩
ILG ; ∪
ILG ; ∀
ILG ; ∃
XWD DF,ALTV ; ⊗ (AN ALTERNATIVE TO ALTMODE FOR FILES)
ILG ; ↔
DOTV-SPACEV ; _
ILG ; →
XWD DF+SSPCF,SENDL ; ~ (↑Z)
↑NEQV: XWD DF+RELBIT,NEOP ; ≠
↑LEV: XWD DF+RELBIT,LEOP ; ≤
↑GEV: XWD DF+RELBIT,GEOP ; ≥
ILG ; ≡
↑ORV: XWD DF+LOGBIT,OROP ; ∨
SPACEV: 0 ; SPACE
DOTV-SPACEV ; ! (AN ALTERNATIVE TO _)
↑QUOTEV: XWD DF+SSPCF,S.QUOTE ; "
.-SPACEV ; #
.-SPACEV ; $
ILG ; %
ILG ; &
ILG ; '
↑LPARV: XWD DF,. ; (
↑RPARV: XWD DF,. ; )
XWD DF+MULBIT,MULOP ; *
↑PLSV: XWD DF+ADDBIT,ADDOP ; +
↑COMMAV: XWD DF,COMMOP ; ,
↑MINV: XWD DF+ADDBIT,SUBOP ; -
↑DOTV: XWD SNUMF,"." ; .
XWD DF+MULBIT,DIVOP ; /
↑CTNUM: REPEAT 12,<XWD SDFLG+SNUMF,20+.-CTNUM> ; THE DIGITS.
↑COLONV: XWD DF+SSPCF,S.COLN ; :
↑SEMICV: XWD DF,. ; ;
↑LTV: XWD DF+SSPCF,S.LT ; < (SEE S.LT IN SCANNER)
↑EQV: XWD DF+RELBIT,EOP ; =
↑GTV: XWD DF+RELBIT,GOP ; >
ILG ; ?
ILG ; @
CTLTR: REPEAT =5,<XWD 0,41+.-CTLTR> ;UPPER CASE LETTERS
41+.-CTLTR ;F
REPEAT =9,<41+.-CTLTR>
XWD FOOBIT,41+.-CTLTR+400000 ;P
REPEAT 4,<41+.-CTLTR>
XWD FOOBIT,41+.-CTLTR
REPEAT 5,<41+.-CTLTR>
↑LFTBRK: XWD DF,. ; [
ILG ; \
↑RGTBRK: XWD DF,. ; ]
↑UARV: XWD DF,EXPOP ; ↑
↑LARV: XWD DF,ASNOP ; ←
ILG ; `
.LCASE: REPEAT =5,<141+.-.LCASE> ;lower case letters
141+.-.LCASE ;f
REPEAT =9,<141+.-.LCASE>
XWD FOOBIT,141+.-.LCASE+400000 ;p
REPEAT 4,<141+.-.LCASE>
XWD FOOBIT,141+.-.LCASE ;u
REPEAT 5,<141+.-.LCASE>
REPEAT 2,<ILG> ;{|
↑ALTV: XWD DF,. ;<ALTMODE>
REPEAT 2,<ILG> ;}<BS>
LALL ;TURN MACRO EXPANSION BACK ON
BEND CHRTAB
; END OF CHARACTER TABLE.
SUBTTL The Reserved word table
DEFINE PUT1 (N,Y)
< FOR X IN (Y)
<Q←<SIXBIT/X/>
N*10000000000+(7777777777&(Q/100))
>>
DEFINE .LENGTH $(FIRST5,REST)
< .COUNT←←0
FOR CHAR ε <FIRST5$REST>
< .COUNT←←.COUNT+1
>>
;PUT WORD IN RESERVED WORD TABLE
DEFINE RESERV $(LSTLST)
< XLIST
.LASTL←←1 ;LAST LENGTH SEEN (ALSO FOR GENSYMing)
RTBL: FOR LIST2 ⊂ (LSTLST)
< RESER1 LIST2
>
↑LRTBL←←.-RTBL
RTBL2: FOR LIST2 ⊂ (LSTLST)
<RESER2 LIST2
>
↑GRTBL←←.-RTBL
SRTBL3: FOR LIST2 ⊂ (LSTLST)
<RESER3 LIST2
>
↑SRTBL1: FOR @% I←2,.LASTL+1
< IFDEF .RT%I < XWD -.RT%I,RT%I%C
>
IFNDEF .RT%I <0
>>
↑MAXRSZ←←.-SRTBL1+3
SRSFOO: JUMP 2*LRTBL(B)
LIST
>
DEFINE RESER1 %(FIRST5,REST,LH,RH,SYM)
< .LENGTH(FIRST5,REST)
IFG .COUNT-.LASTL
<CAT(RT,→.COUNT)%C: .LASTL←←.COUNT
CAT(.RT,→.LASTL)←←0
>
PUT1(.COUNT,FIRST5)
CAT(.RT,→.LASTL)←←CAT(.RT,→.LASTL)+1
>
DEFINE RESER2 %(FIRST5,REST,HL,RH,SYM)
< .LENGTH(FIRST5,REST)
IFLE .COUNT-5 <0
>
IFG .COUNT-5 <SIXBIT/REST/
>>
DEFINE RESER3 %(FIRST5,REST,LH,RH,SYM)
<↑SYM: XWD LH,RH
>
XALL ;TURN OFF MACRO EXPANSION
BEGIN RSRVTB
; <FIRST 5 CHARACTERS>,<REST OF CHARACTERS>,<GOOD BITS>,<ADDRESS>,<TOKEN NAME>
;
; GENERATES # TABLES
;
;RTBL: ;LIST OF SIXBIT BTYES CONTAINING CHARACTER COUNT AND
; ;THE FIRST FIVE CHARACTERS
;RTBL2: ;LIST OF REMAINING CHARACTERS, CORRESPONING TO ORDER IN
; ;RTBL
;RTBL2: ;LIST OF XWD <RANDOM GOODBITS>,<COMPILER ROUTINE>
; ;CORRESPONING TO ORDER IN RTBL
;SRTBL1: ;XWD <NUMBER OF ENTRYS>,<ENTRY IN RTBL> IN ORDER OF
; ;CHARACTER COUNTS
RESERVE <<DO,, RF+RSTMTBT,COMDO,DOV>
,<IF,, RF+RSTMTBT,COMIF,IFV>
,<PI,, FLTFLG,PI,PIV>
,<END,, RF,.,ENDV>
,<FOR,, RF+RSTMTBT,COMFOR,FORV>
,<DONE,, RF+RSTMTBT,COMDONE,DONEV>
,<ELSE,, RF+RSTMTBT,BADELSE,ELSEV>
,<EXIT,, RF+RSTMTBT,COMEXIT,EXITV>
,<FINI,, RF,.,FINIV>
,<LIST,, RF,.,LISTV>
,<PLAY,, RF,.,PLAYV>
,<STEP,, RF,.,STEPV>
,<THEN,, RF,.,THENV>
,<ARRAY,, RF+DECLBIT,DARR,ARRV>
,<BEGIN,, RF+RSTMTBT,CBLOCK,BEGINV>
,<PRINT,, FUNBIT,.PRINT,PRINTV>
,<UNTIL,, RF,.,UNTILV>
,<WHILE,, RF+RSTMTBT,CWHILE,WHILEV>
,<FINIS,H, RF,.,FINV>
,<I.ONL,Y, RF+RSTMTBT,CIONLY,IONLYV>
,<LENGT,H, FUNBIT,.LEN,LENV>
,<RETUR,N, RF+RSTMTBT,COMRET,RTURNV>
,<RPRIN,T, FUNBIT,.RPRINT,RPRINV>
,<STRIN,G, RF+DECLBIT,.STRIN,STRV>
,<COMME,NT, SSPCF,.COMME,COMV>
,<INTEG,ER, RF+DECLBIT,.INTEG,INTGV>
,<R.PRI,NT, RF+RSTMTBT,COMRPRT,RPRNTV>
,<VARIA,BLE, RF+DECLBIT,DVRBL,VARV>
,<FUNCT,ION, RF+DECLBIT,DFUNC,FUNV>
,<EXTER,NAL, RF+DECLBIT,EXTD,EXTV>
,<INSTR,UMENT, RF+DECLBIT,CINS,INSV>
,<UNIT.,GENERATOR,RF+DECLBIT,.UG,UGV>
>
LALL ;TURN MACRO EXPANSION BACK ON
;Random functions
.PRINT: FUNBIT,,.+1
JSA RA,FOOPRT
BYTE (6) 1,VARPAR,0,0
.RPRIN: FUNBIT,,.+1
JSA RA,@FOOPRT
BYTE (6) 1,VARPAR,0,0
↑.LEN: FUNBIT,,.+2
JSA RA,STRLEN
JSA RA,ARRLEN
BYTE (6) 1,STAPAR,0,1
.INTEG: JFCL ;THE JFCLS INSURE A UNIQUE ADDRESS FOR STRQ AND INTGV
.STRIN: ERROR <Illegal declaration>
COMMENT ⊗ You may not make a declaration of type STRING or INTEGER. ⊗;
BADELSE: ERROR <Dangling ELSE or extraneous ';' in IF...THEN...ELSE statement>
COMMENT ⊗ The statement following the 'THEN' in a IF...THEN...ELSE statement is terminated
by the ELSE and should not have a semicolon after it. ⊗;
JRST BADELSE
BEND RSRVTB
SUBTTL The Main Symbol Table
;HERE'S THE BLOODY SYMBOL TABLE --- A LINKED LIST
;PUT SYMBOL IN SYMBOL TABLE
;NEXT TIME I'M IN SOS I SHOULD FIX THIS
DEFINE ENTSYM &(FIRST5,REST,LH,RH)
< XLIST
.TMP1←←<SIXBIT/ FIRST5/>
FOR .CHAR ε <FIRST5&REST> < .TMP1←←.TMP1+1B5
>
.TMP2←←.TMP1-(.TMP1/BUCKNO)*BUCKNO
CAT(SYM,→.TMP2)
CAT(SYM,→.TMP2)←←$.-1
.TMP1
IFDIF <RH><>< XWD LH,RH >
IFIDN <RH><>< XWD LH,$.+1+(.TMP1/1B5)/6 >
SIXBIT/REST/
LIST
>
XALL ;TURN OFF MACRO EXPANSION
ENTSYM OSCIL,,UGBIT, .+2
COMMENT ⊗ Unit generator *Simple oscillator ⊗;
0
JSP RA,@OSCIL ;POINTER DID NOT RESET WITH '1,5,0,1' IN NEXT!!!!
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPART,0,1
;***** JULY 3,71 THIS ENDED '1,TMPPAR,0,1' ****
ENTSYM ZOSCI,L,UGBIT, .+3
COMMENT ⊗ Unit generator *Interpolating oscillator ⊗;
0
JSP RA,@ZOSCIL
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPART,0,1
ENTSYM ZOSCA,,UGBIT, .+2
COMMENT ⊗ Unit generator *Interpolating oscillator with starting point given ⊗;
JSA RA,INOSCA
JSP RA,@ZOSCA
BYTE (6)5,VARPAR,VARPAR,VARPAR,ARRPAR,TMPPART,0,1
ENTSYM CZOSC,IL,UGBIT, .+3
COMMENT ⊗ Unit generator *Interpolating version of COSCIL ⊗;
0
JSP RA,@ZOSCIL
BYTE (6)4,VARPAR,VARPAR,ARRPAR,TMPPART,0,1
ENTSYM SRATE,,VRBLBT, SRATE
COMMENT ⊗ Variable *Sampling rate ⊗;
↑SRATE: 10000.0
ENTSYM NCHNS,,VRBLBT, NCHNS
COMMENT ⊗ Variable *Number of channels active ⊗;
↑NCHNS: 1
ENTSYM LSBUF,,VRBLBT, LSBUF
COMMENT ⊗ Variable *Current size of DAC buffer ⊗;
↑LSBUF: 1000
ENTSYM OUT,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Equivalent to OUTA←OUTA+X ⊗;
0
JSA RA,@OUT
BYTE (6)1,VARPAR,0,0
ENTSYM OUT2,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Equivalent to ≤FUNCTION OUT2(X,CH1,CH2); BEGIN
OUTA←OUTA+X*CH1; OUTB←OUTB+X*CH2; END;≥ ⊗;
0
JSA RA,@OUT2
BYTE (6)3,VARPAR,VARPAR,VARPAR,0,0
ENTSYM DA.SE,CONDS,VRBLBT, DA.SEC
COMMENT ⊗ Variable *Number of seconds of sound to buffer in core for DAC ⊗;
↑DA.SEC: 0
ENTSYM SPEED,,VRBLBT, SPEED
COMMENT ⊗ Variable *Speed at which to run DAC (see SETCLOCK) ⊗;
↑SPEED: 1
ENTSYM VFMUL,T,UGBIT, .+3
COMMENT ⊗ Unit Generator *Multiplies amplitude by array element ⊗;
0
JSP RA,@VFMULT
BYTE (6)3,VARPAR,VARPAR,ARRPAR,0,T
ENTSYM NOSCI,L,UGBIT, .+3
COMMENT ⊗ Unit Generator *Oscillator which accepts negative increments ⊗;
0
JSP RA,@NOSCIL
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPAR,0,1
ENTSYM NOSCA,,UGBIT, .+2
COMMENT ⊗ Unit generator *Oscillator with starting point given ⊗;
JSA RA,INOSCA
JSP RA,@NOSCA
BYTE (6)5,VARPAR,VARPAR,VARPAR,ARRPAR,TMPPAR,0,T
ENTSYM INTRP,,UGBIT, .+2
COMMENT ⊗ Unit generator *Interpolator driven by oscillator ⊗;
JSA RA,IINTRP
JSP RA,@INTRP
BYTE (6)5,VARPAR,VARPAR,TMPPAR,ARRPAR,ZTMPPAR,0,T
ENTSYM ZINTR,P,UGBIT, .+3
COMMENT ⊗ Unit generator *Interpolator driven by interpolating oscillator ⊗;
JSA RA,IINTRP
JSP RA,@ZINTRP
BYTE (6)5,VARPAR,VARPAR,TMPPAR,ARRPAR,ZTMPPAR,0,T
ENTSYM OUTA,,VRBLBT+RVBT, OUTA
COMMENT ⊗ Variable *Output channel A ⊗;
ENTSYM OUTB,,VRBLBT+RVBT, OUTB
COMMENT ⊗ Variable *Output channel B ⊗;
ENTSYM OUTC,,VRBLBT+RVBT, OUTC
COMMENT ⊗ Variable *Output channel C ⊗;
ENTSYM OUTD,,VRBLBT+RVBT, OUTD
COMMENT ⊗ Variable *Output channel D ⊗;
ENTSYM MAXSM,P,VRBLBT+RVBT, MAXSMP
COMMENT ⊗ Variable *Maximum sample seen ⊗;
ENTSYM P.ARR,AY,ARRYBT, PBASE
COMMENT ⊗ Array *P1,P2,P3,... ⊗;
ENTSYM DEBUG,FLAG,VRBLBT, DEBUGF
COMMENT ⊗ Variable *Enables various compiler debugging features ⊗;
ENTSYM NO.MS,G,VRBLBT, NO.MSG
COMMENT ⊗ Variable *If nonzero, disable compiler messages ⊗;
; ENTSYM DOPLA,Y,VRBLBT, DOPLAY#
;DOPLAY←1=WILL PLAY WHEN WRITING SMPLS ON DSK
ENTSYM BITS,,VRBLBT, BITS ;TO SET BYTESIZE
COMMENT ⊗ Variable BYTE SIZE 12.0 OR 18.0 ⊗;
↑BITS: 12.0 ; DEFAULT VALUE
ENTSYM OUTFI,LE,VRBLBT!STRFLG, OUTFIL
COMMENT ⊗ String *Output specification ⊗;
ENTSYM INFIL,E,VRBLBT!STRFLG, INFILE
COMMENT ⊗ FOR READIN FILE NAMES ⊗;
ENTSYM SAVIT,,VRBLBT, SAVIT ;TO SET SAVE FEATURE
COMMENT ⊗ FOR SAVE FEATURE ⊗;
↑SAVIT: 0 ; DEFAULT VALUE (NO SAVE)
ENTSYM .SKIP,.,VRBLBT, .SKIP.
COMMENT ⊗ Variable *Used by obscure external routines to record failures ⊗;
ENTSYM VALUE,,UGBIT, .+2
COMMENT ⊗ Unit generator *Returns its first argument ⊗;
0
JSP RA,@VALUE
BYTE (6)1,VARPAR,0,T
ENTSYM RAND,,FUNBIT
COMMENT ⊗ Function *Returns a pseduo-random number between -1 and 1 ⊗
PUSHJ P,RAND
BYTE (6)0,T
ENTSYM INT,,FUNBIT
COMMENT ⊗ Function *Returns integer part of floating point number ⊗;
JSA RA,INT
BYTE (6)1,VARPAR,0,0
ENTSYM ARRBL,T,FUNBIT
COMMENT ⊗ Function *Copies N elements between two arrays ⊗;
JSA RA,ARRBLT
BYTE (6)3,VARPAR,VARPAR,INTPAR,0,1
ENTSYM ABS,,FUNBIT
COMMENT ⊗ Function *Returns absolute value of number ⊗;
JSA RA,[ABS: 0
MOVM 1,@(RA)
JRA RA,1(RA)]
BYTE (6)1,VARPAR,0,1
ENTSYM LINEN,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Three part oscillator ⊗;
JSA RA,LINEN1
JSP RA,@LINEN
BYTE (6)13,ZTMPPART,ZTMPPART,ZTMPPART,VARPAR,VARPAR
BYTE (6)VARPAR,VARPAR,ARRPAR,VARPAR,ZTMPPART,ZTMPPART,0,1
;NOW YOU MUST RESET PTR IN LINEN
ENTSYM EXPEN,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Oscillator which doesn't wrap around ⊗;
0
JSP RA,@EXPEN
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPART,0,1
ENTSYM ZEXPE,N,UGBIT, .+3
COMMENT ⊗ Unit Generator *Interpolating oscillator without wrap around ⊗;
0
JSP RA,@ZEXPEN
BYTE (6)4,VARPAR,VARPAR,ARRPAR,ZTMPPART,0,1
ENTSYM REV1,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Comb Filter (Reverberator) ⊗;
JSP RA,REVI
JSP RA,@REV1
BYTE (6)6,VARPAR,VARPAR,VARPAR,ARRPAR,TMPPAR,ZTMPPART,0,1
ENTSYM REV2,,UGBIT, .+2
COMMENT ⊗ Unit Generator *All-Pass Reverberator ⊗;
JSP RA,REVI
JSP RA,@REV2
BYTE (6)6,VARPAR,VARPAR,VARPAR,ARRPAR,TMPPAR,ZTMPPART,0,1
ENTSYM DELAY,,UGBIT, .+2
COMMENT ⊗ Unit Generator *Simple Delay ⊗;
JSP RA,REVI
JSP RA,@DELAY
BYTE (6)6,VARPAR,VARPAR,TMPPAR,ARRPAR,TMPPAR,ZTMPPART,0,1
ENTSYM REVIN,IT,VRBLBT, REVINI
COMMENT ⊗ Unit generator *If nonzero, reverberator arrays are zeroed when
initialized ⊗;
↑REVINI: 0
ENTSYM RANDH,,UGBIT, .+2
COMMENT ⊗ Unit generator *Oscillator controlled random numbers with hold ⊗
JSP RA,IRANDH
JSP RA,@RANDH
BYTE (6)4,VARPAR,VARPAR,ZTMPPART,ZTMPPART,0,1
ENTSYM RANDI,,UGBIT, .+2
COMMENT ⊗ Unit generator *Oscillator controlled random numbers with
interpolation ⊗
JSP RA,IRANDI
JSP RA,@RANDI
BYTE (6)5,VARPAR,VARPAR,ZTMPPART,ZTMPPART,ZTMPPART,0,1
ENTSYM COSCI,L,UGBIT, .+3
COMMENT ⊗ Unit generator *Oscillator which remembers pointer between
instrument calls ⊗;
0
JSP RA,@NOSCIL
BYTE (6)4,VARPAR,VARPAR,ARRPAR,TMPPAR,0,1
LALL ;TURN MACRO EXPANSION BACK ON
SUBTTL Statement Compilation
;<Statement list> ::= <Statement>;<Statement list> | END
SSTATL: PUSHJ P,SMCSCN ;SCAN NEXT NON-SEMICOLON.
STATL: CAME A,ENDV
PUSHJ P,STAT ;NO. SCAN A STATEMENT.
ORM H,RSTATE ;SAVE R-STATE
CAMN A,ENDV ;IS IT AN END ?
POPJ P, ;YES.
CAMN A,SEMICV ;IS IT A SEMICOLON?
JRST SSTATL ;YES, GO BACK FOR MORE.
WARN <Missing ';'> ;OH WELL...
COMMENT ⊗ Statements should be terminated with a semicolon ⊗;
JRST STATL
;<statement> ::= <assignment statement>|<function call>|<unit generator call>|
; <block>|<for statement>
SSTAT: PUSHJ P,SMCSCN
STAT: MOVEI H,0 ;CLEAR 'R-TIME CODE' FLAG.
JUMPGE A,STMT1 ;A DELIMITER ?
TLNE A,RSTMTBT ;RESERVED WORD FOR STATEMENT
JRST (A)
TLNE A,DECLBIT
JRST [ OUTPUT TTY,
WARN <Declarations should be made at start of block>
COMMENT ⊗ You may continue from this error. ⊗;
JRST (A)]
WARN <Unexpected symbol beginning a statement>
COMMENT ⊗ It will be ignored and attempt to continue compilation. ⊗;
JRST SSTAT
;<STMT1> ::= <FUNCTION CALL> | <UNIT GENERATOR CALL> | <ASN. STMT>
SSTMT1: PUSHJ P,SCAN
STMT1: SKIPN A ;IS IT UNDEFINED ?
ERROR <UNDEFINED IDENTIFIER>
TLNE A,FUNBIT
JRST [ CAMN A,PRINTV ;IS IT A PRINT STATEMENT?
JRST COMPRT ;YES, COMPILE
CAMN A,RPRINV ;IS IT A RPRINT STATEMENT?
JRST COMRPRT
PUSHJ P,FUNCAL ;NO, IT'S A FUNCTION CALL
JRST SCAN] ;RETURN.
TLNE A,UGBIT
JRST [ TRNN FL,INSDEF ;BETTER BE AN INSTRUMENT DEFINITION
ERROR <Unit Generator call illegal outside of instrument definition>
COMMENT ⊗ Unit generators are only to be used inside of instruments as they require
special initialization at I-time. ⊗;
PUSHJ P,UGCALL ;COMPILE A UNIT GENERATOR CALL
JRST SCAN]
TLNN A,ARRYBT!VRBLBT!FOOBIT ;BETTER BE A VARIABLE.
JRST [ WARN <Unexpected symbol beginning a statement>
COMMENT ⊗ It will be ignored and attempt to continue compilation. ⊗;
JRST SSTAT ]
PUSH OSP,A ;STACK IT.
TLNE A,ARRYBT ;IS IT AN ARRAY?
PUSHJ P,SCSUBSC ;YES, COMPILE SUBSCRIPT
STMT1B: PUSHJ P,SCAN ;GET LEFT ARROW.
CAMN A,LARV
JRST STMT1C
CAME A,EQV ;CATCH A COMMON ERROR (= FOR ←) BUT ACCEPTABLE NOW.
ASNERR: ERROR <Expected to find a '←' here> ;THE FATAL ONE
COMMENT ⊗ The compiler assumed you had begun an assignment statement. ⊗;
;;;; WARN <PLEASE Use a '←' assignment next time>
COMMENT ⊗ However '=' will be accepted under protest. ⊗;
STMT1C: PUSHJ P,ASTMT1 ;IT'S AN ASSIGNMENT STMT. COMPILE IT.
JRST POPAJ ;RESTORE A(WHICH WAS SAVED BY ASTMT)
; AND RETURN.
SMSC1:
SMCSCN: PUSHJ P,SCAN ;SCAN PAST NEXT SEMICOLON.
SMCS1: CAMN A,SEMICV
JRST SMCSCN
POPJ P,
;ANOTHER DECLARATION
EXTD: PUSHJ P,SCAN ;"EXTERNAL" DECLARATION.
CAMN A,UGV
JRST UGDEF
CAME A,FUNV ;BETTER BE "FUNCTION".
ERROR <External functions only, please>
COMMENT ⊗ The compiler does not know about anything else being external. ⊗;
TRO FL,EXTFLG ;SET FLAG.
PUSHJ P,DFUNC
TRZ FL,EXTFLG ;CLEAR IT
POPJ P,
;I DON'T KNOW QUITE WHERE TO PUT THIS SO IT GOES HERE.
;<I-only statement> ::= I_ONLY <statement>
;
CIONLY: PUSH P,IONLY ;SAVE AND THEN SET IONLY FLAG
SETOM IONLY
PUSHJ P,SSTAT ;COMPILE RANDOM STATEMENT
POP P,IONLY ;RESTORE STATE OF IONLY
POPJ P, ;RETURN
; Block Statement (BEGIN...END)
;
;<block> ::= BEGIN <statement list>; END
;
CBLOCK: DEBUG2 <ENTERING BLOCK>
AOS BLEVEL ;INCREMENT BLOCK LEVEL
JSR PUSHBUCTBL ;SAVE SYMBOL TABLE POINTERS
PUSH P,EXITFX ;SAVE OLD FIXUP
SETZM EXITFX
PUSH P,EXITFX+1
SETZM EXITFX+1
PUSHJ P,SCAN ;SKIP OVER 'BEGIN'
CBLOC1: PUSHJ P,SMCS1 ;SCAN OPTIONAL ';'
JUMPGE A,CBLOC2
TLNN A,DECLBIT ;A DECLARATION?
JRST CBLOC2 ;NO
PUSHJ P,(A) ;YES, DO DECLARATION
CAME A,SEMICV ;BETTER BE A SEMICOLON
WARN <Missing ';'> ;OH WELL
COMMENT ⊗ Statements should be terminated with a semicolon ⊗;
JRST CBLOC1
CBLOC2: PUSHJ P,STATL
MOVE H,RSTATE ;SET H TO R-TIME STATUS OF BLOCK
SETZM RSTATE
SKIPN A,EXITFX ;ANY EXIT STATEMENTS?
JRST CBLOC3 ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
MOVEI B,.FXBTS
PUSHJ P,EMICD
SKIPN A,EXITFX+1;ANY R-TIME FIXUPS?
JRST CBLOC3 ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
PUSHJ P,EMCD
CBLOC3: POP P,EXITFX+1
POP P,EXITFX
JSR POPBUCTBL ;RESTORE SYMBOL TABLE POINTERS
DEBUG2 <LEAVING BLOCK>
SOSL BLEVEL
JRST SCAN ;SCAN AND RETURN
ERROR <Too many END statements>
; DONE, EXIT, and RETURN
;
COMDONE: SKIPGE B,DONEFX ;FOR CHAIN FIXUP, ALSO CHECK TO MAKE SURE DONE IS OK
ERROR <DONE statement illegal here>
MOVE A,ILOC
MOVEM A,DONEFX ;NEW LINK IN CHAIN
SETZ A,
MOVE C,[JRST EMICDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF LOOP STATEMENT
SKIPE IONLY ;I-TIME ONLY?
JRST SCAN ;YES, SCAN AND RETURN
MOVE B,DONEFX+1 ;FOR R-TIME TOO, THEN
MOVE A,RLOC
MOVEM A,DONEFX+1
SETZ A,
MOVE C,[JRST EMCDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF LOOP STATEMENT
JRST SCAN ;YES, SCAN AND RETURN
COMEXIT: SKIPGE B,EXITFX
ERROR <EXIT statement illegal outside of block>
MOVE A,ILOC
MOVEM A,EXITFX ;NEW LINK IN CHAIN
SETZ A,
MOVE C,[JRST EMICDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF LOOP STATEMENT
SKIPE IONLY ;I-TIME ONLY?
JRST SCAN ;YES, SCAN AND RETURN
MOVE B,EXITFX+1 ;FOR R-TIME TOO, THEN
MOVE A,RLOC
MOVEM A,EXITFX+1
SETZ A,
MOVE C,[JRST EMCDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF LOOP STATEMENT
JRST SCAN ;YES, SCAN AND RETURN
COMRET: PUSHJ P,SCAN
MOVEM A,SAVSYM ;SAVE SYMBOL
PUSHJ P,STMTRM ;IS IT A STATEMENT TERMINATOR?
JRST COMRE2 ;YES, NO VALUE
PUSHJ P,EXPR ;COMPILE A EXPRESSION
MOVEM A,SAVSYM
PUSHJ P,GMURK1 ;GET IT OFF STACK.
SETZ A,
MOVE B,E ;AND READY TO EMIT INSTRUCTION
MOVSI C,(<MOVE>)
CAME B,[XWD SIACBT,0] ;IS IT ALREADY IS AC 0?
PUSHJ P,EMINST ;NO, LOAD INTO AC 0
COMRE2: SKIPGE B,RETFIX
ERROR <RETURN statement illegal outside of function definition>
COMMENT ⊗ Only functions may return a value. Use EXIT to leave a block. ⊗;
MOVE A,ILOC
MOVEM A,RETFIX
SETZ A,
MOVE C,[JRST EMICDI]
PUSHJ P,EMINST ;EMIT JRST TO END OF FUNCTION DEFINITION
MOVE A,SAVSYM ;RESTORE SAVED SYMBOL
POPJ P,
; PRINT Statement
;
;<PRINT statement> ::= PRINT <print list>|R_PRINT <print list>
;<print list> ::= <expression>,<print list>|<expression>|
; <string constant>,<print list>|<string constant>
;
;Code generated for numeric PRINT
; JSA RA,FOOPRT
; <pointer to value>
;
;Code generated for string PRINT
; TTYUUO 3,<address of string>
;
COMRPRT: MOVEI 1
SKIPN IONLY ;DON'T UNDO THIS, IT WILL CAUSE PROBLEMS!
MOVEM RPRINT ;SET R-TIME PRINT KLUDGE FLAG
SKIPA
COMPRT: SETZM RPRINT# ;MORE OF THAT KLUDGE
PUSHJ P,SCAN ;GET NEXT IDENTIFIER
TLNE A,STRFLG ;IS IT A STRING?
JRST [ MOVE B,A ;EMIT AN OUTSTR!
TLZ B,STRFLG ;STRFLG CONFUSES THE LOADER!
TLNE B,777777 ;IS IT A FORMAL OR SOMETHING
HRR B,(B) ;YES, GET REAL ADDRESS
MOVEI A,3 ;OUTSTR = TTYUUO 3,STRING_ADDRESS
MOVSI C,(<TTYUUO>)
TLNE B,VRBLBT ;A string variable?
TLO C,20 ;Turn on indirect bit
SKIPE RPRINT ;IS IT R-TIME KLUDGE?
HRRI C,EMCDI ;YES, BARF!
PUSHJ P,EMINST
PUSHJ P,SCAN ;GET NEXT SYMBOL
JRST COMPR2] ;GO BACK FOR MORE
PUSHJ P,EXPR ;NO, IT MUST BE AN EXPRESSION
PUSH P,A ;SAVE SCANNED CHARACTER
OR H,RPRINT ;R_PRINT KLUDGE
PUSHJ P,GMURK1 ;GET EXPRESSION
TLNE E,FPARBT ;IS IT A FORMAL?
JRST [ PUSHJ P,GETAC ;YES, COPY PARAMETER INTO TEMPORARY
MOVE B,E
MOVSI C,(<MOVE>)
PUSHJ P,EMINST ;EMIT FETCH FOR PARAM.
MOVE B,VLOC
MOVEM B,E ;CHANGE ADDRESS OF PRINT ARG. TO TEMP.
MOVSI C,(<MOVEM>)
PUSHJ P,EMINST ;EMIT STORE INTO TEMP.
PUSHJ P,EMDV ;SAVE SPACE FOR TEMP
JRST COMPR3]
COMPR3: MOVE A,[JSA RA,FOOPRT] ;EMIT A FUNCTION CALL TO PRINT NUMBER
SETZ B,
PUSHJ P,@EMITB(H)
MOVE B,E
SETZB A,C
PUSHJ P,EMINST ;EMIT IT
POP P,A ;GET BACK SCANNED SYMBOL
COMPR2: CAMN A,COMMAV ;IS IT A COMMA?
JRST COMPRT ;YES, GET ANOTHER THING TO PRINT
POPJ P, ;NO, RETURN
; IF-THEN-ELSE statement
;
;<IF-THEN statement> ::= IF <expression> THEN <statement> ELSE <statement>|
; IF <expression> THEN <statement>
;
;Code Generated for IF-THEN Code generated for IF-THEN-ELSE
; <Skip on condition true> <Skip on condition true>
; JRST G0001 JRST G0001
; SETOM <flag> SETOM <flag>
; <True statement> <True statement>
; JRST .+2 JRST G0002
;G0001: SETZM <flag> G0001: SETZM <flag>
; <False statment>
; G0002:
;
COMIF: PUSHJ P,SLEXPR ;COMPILE THE CONDITIONAL PART
CAME A,THENV
WARN (Missing 'THEN')
COMMENT ⊗ 'THEN' Missing in IF...THEN...ELSE Statement. ⊗;
JUMPN H,COMRIF ;IF IT WAS AN R-TIME CONDITIONAL
MOVE A,VLOC ;EMIT CODE TO SKIP IN R-TIME CODE ACCORDING TO
HLRZ B,VLOC ;A CERTAIN FLAG WE'RE ABOUT TO CREATE
HRLI A,(<SKIPN>)
SKIPN IONLY ;DON'T BOTHER IF WE'RE JUST GENERATING I-TIME CODE
PUSHJ P,EMCDI
PUSH P,VLOC ;SAVE ADDRESS OF THIS CERTAIN FLAG
SKIPN IONLY ;IF WE MAY BE GENERATING R-TIME CODE, INC. THE
AOS VLOC ;VARIABLE COUNTER
PUSH P,RLOC ;AND THE ADDRESSES OF THE FOLLOWING 'JRST' FOR FIXUPS
PUSH P,ILOC ;(G0001)
MOVSI A,(<JRST>)
SETZ B,
PUSHJ P,EMICDI ;TO JUMP AROUND 'THEN' PART ON CONDITION FALSE
SKIPN IONLY ;DO WE NEED TO DO IT FOR R-TIME TOO?
PUSHJ P,EMCDI ;YES, EMIT IT THEN
MOVE A,-2(P) ;STACK = [...FLAG, R-FIXUP, I-FIXUP]
HRLI A,(<SETOM>)
HLRZ B,VLOC
SKIPN IONLY
PUSHJ P,EMICDI ;AND EMIT CODE TO SET THAT FLAG
PUSHJ P,SSTAT ;COMPILE A STATEMENT
CAMN A,ELSEV ;DOES IT HAVE AN 'ELSE` CLAUSE?
JRST CIELSE ;YES, GO SOMEWHERE ELSE TO DO IT.
PUSH OSP,A ;SAVE IT ON THE OPERAND PDL FOR CONVIENCE
HRRZ A,ILOC
ADD A,[JRST 2] ;(FASTER THAN A SKIP) SKIP OVER I-TIME CODE TO
HLRZ B,ILOC ;SET FLAG FOR USE BY R-TIME
SKIPN IONLY ;UNLESS WE'RE JUST COMPILING I-TIME CODE
PUSHJ P,EMICDI
COMIF7: PUSHJ P,[ ;DO FIXUPS FOR I-TIME AND R-TIME CODE (G0001)
;STACK = [...FLAG, R-FIXUP, I-FIXUP, RETURN ADDRESS]
;(FLUSHES TOP TWO STACK ELEMENTS + RETURN ADDRESS)
FIXBTH: POP P,A ;GET RETURN ADDRESS
EXCH A,-1(P) ;SWAP IT WITH R-TIME FIXUP
MOVEI B,.FXBTS
SKIPN IONLY ;DON'T BOTHER IF WE JUST COMPILING I-TIME
PUSHJ P,EMCD ;FIXUP FOR R-TIME
POP P,A ;DO I-TIME FIXUP
PUSHJ P,EMICD
POPJ P,] ;RETURN
PUSHJ P,[ ;EMIT CODE TO SKIP FLAG (FLUSHES TOP OF STACK + R.A.)
;STACK = [...FLAG, RETURN ADDRESS]
CLRSKP: POP P,A ;GET FLAG FOR R-TIME SKIP
EXCH A,(P)
HRLI A,(<SETZM>);TO CLEAR IT IF CONDITION FALSE
HLRZ B,VLOC ;GET VARIABLE RELOCATION
SKIPN IONLY ;BUT DON'T EMIT IF WE JUST COMPILING I-TIME CODE
PUSHJ P,EMICDI
POPJ P,]
OPOPAJ: POP OSP,A ;GET BACK SCANNED SYMBOL
POPJ P, ;AND RETURN
CIELSE: MOVSI A,(<JRST>);EMIT JRST TO AROUND 'ELSE` CLAUSE (JRST G0002)
SETZ B,
PUSHJ P,EMICDI ;FOR I-TIME
SKIPN IONLY ;AND R-TIME CODE IF NECESSARY
PUSHJ P,EMCDI
PUSHJ P,FIXBTH ;DO FIXUPS FOR JRSTS TO 'ELSE` CLAUSE (G0001)
PUSHJ P,CLRSKP
PUSH P,RLOC ;AND SAVE POINTERS FOR OTHER FIXUPS (G0002)
SOS (P) ;BLETCH!
PUSH P,ILOC
SOS (P)
SKIPN IONLY
SOS (P)
PUSHJ P,SSTAT ;COMPILE THE 'ELSE` CLAUSE
PUSH OSP,A
PUSHJ P,FIXBTH ;DO FIXUPS TO JRST AROUND 'ELSE' CLAUSE (G0002)
JRST OPOPAJ
; IF-THEN-ELSE statement - (R-TIME)
COMRIF: MOVSI A,(<JRST>);EMIT JRST AROUND 'THEN` CLAUSE
SETZ B,
PUSH P,RLOC ;SAVE FOR FIXUP
PUSHJ P,EMCDI
PUSHJ P,SSTAT ;COMPILE 'THEN` CLAUSE
PUSHJ P,IFRCHK ;MAKE SURE SOMETHING WAS GENERATED AT R-TIME
CAMN A,ELSEV ;IS THERE AN 'ELSE` CLAUSE?
JRST CRELSE ;YES, JUMP OFF TO COMPILE IT
COMIF8: EXCH A,(P) ;SAVE SCANNED SYMBOL AND GET ADDRESS OF JRST TO FIXUP
MOVEI B,.FXBTS ;AND THE FIXUP BITS
PUSHJ P,EMCD
JRST POPAJ ;RECOVER SCANNED SYMBOL AND RETURN
;AN R-TIME ELSE
CRELSE: MOVSI A,(<JRST>);EMIT JRST AROUND THE 'ELSE` CLAUSE
SETZ B,
PUSHJ P,EMCDI
MOVE A,RLOC
SUBI A,1 ;BLETCH!
EXCH A,(P) ;SAVE POINTER TO PREVIOUS JRST AND GET FIXUP FOR
MOVEI B,.FXBTS ;JRST TO ELSE CLAUSE
PUSHJ P,EMCD ;EMIT FIXUP
PUSHJ P,SSTAT ;COMPILE THE 'ELSE` CLAUSE
PUSHJ P,IFRCHK ;MAKE SURE THERE WAS SOMETHING GENERATED AT R-TIME
JRST COMIF8 ;FIXUP THE JRST AROUND 'ELSE` CLAUSE, RECOVER
;SCANNED SYMBOL AND RETURN!
IFRCHK: MOVE B,-1(P) ;WAS THERE ANY R-TIME CODE GENERATED?
ADDI B,1
CAMN B,RLOC
WARN <R-Time conditional for I-time IF-THEN-ELSE statement> ;NO!!!
COMMENT ⊗ No R-time code was generated after an R-Time conditional. Therefore
the IF-THEN statement acts as if the condition were always true for the 'THEN'
clause and always false for the 'ELSE' clause! ⊗;
POPJ P,
; WHILE statement
;
; THIS COULD BE RECODED TO BE MORE EFFICIENT BY USING NEW DONES IN PLACE OF
; SAVING G0002 ON THE STACK
;
;<WHILE statement> ::= WHILE <expression> DO <statement>
;
;Code Generated:
;G0001: <Skip on condition true>
; JRST G0002
; <Statement>
; JRST G0001
;G0002:
;
CWHILE: DEBUG(WHILE statement)
PUSH P,DONEFX ;SAVE DONE FIXUPS
PUSH P,DONEFX+1
SETZM DONEFX
SETZM DONEFX+1
PUSH P,ILOC ;SAVE ADDRESS OF BEG. OF WHILE
PUSH P,RLOC
PUSHJ P,SLEXPR ;COMPILE CONDITION
CAME A,DOV ;BETTER BE A 'DO`
WARN <Missing DO in WHILE statement>
MOVSI A,(<JRST>);GET READY TO EMIT JRST AROUND STATEMENT
SETZ B,
JUMPN H,CRWHILE ;HANDLE R-TIME SEPARATELY
POP P,(P) ;FLUSH SAVED R-TIME POINTER
PUSH P,ILOC ;SAVE ADDRESS OF JRST AROUND STATEMENT
PUSHJ P,EMICDI
PUSH P,IONLY ;NO, MARK IT I-TIME ONLY CODE
SETOM IONLY
PUSHJ P,SSTAT ;COMPILE THE STATEMENT PART
POP P,IONLY ;RESTORE I-ONLY FLAG
EXCH A,-1(P) ;SAVE SCANNED SYMBOL AND GET POINTER TO BEG. OF
HLRZ B,A ;WHILE STATEMENT TO EMIT JRST BACK
HRLI A,(<JRST>)
PUSHJ P,EMICDI
POP P,A ;EMIT FIXUP TO JRST AROUND STATEMENT
MOVEI B,.FXBTS
PUSHJ P,EMICD
POP P,SAVSYM# ;RECOVER SCANNED SYMBOL
JRST LOOPDN
;R-TIME WHILE STATEMENT
CRWHIL: PUSH P,RLOC ;SAVE POINTER FOR FIXUP
PUSHJ P,EMCDI ;EMIT JRST AROUND STATEMENT
PUSHJ P,SSTAT ;COMPILE THE STATEMENT PART
MOVE B,(P)
ADDI B,1
CAMN B,RLOC ;WAS ANY R-TIME CODE GENERATED
WARN <R-Time condition for I-Time Statement in WHILE statement> ;NO!!!
COMMENT ⊗ No R-Time code was generated after an R-Time conditional. It is
most likely that this will result in an infinite loop! ⊗;
EXCH A,-1(P) ;SAVE SYMBOL AND GET ADDRESS OF BEG. OF WHILE
HLRZ B,A
HRLI A,(<JRST>) ;EMIT A JRST BACK TO BEGINNING OF WHILE
PUSHJ P,EMCDI
POP P,A ;EMIT FIXUP AROUND STATEMENT
MOVEI B,.FXBTS
PUSHJ P,EMCD
POP P,SAVSYM# ;RECOVER SCANNED SYMBOL
POP P,(P) ;FLUSH I-TIME POINTER
; DO ANY FIXUPS REQUIRED BY DONES, ETC
LOOPDN: MOVEI B,.FXBTS
SKIPN A,DONEFX ;ANY I-TIME DONE STATEMENTS?
JRST LOOPD1 ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
PUSHJ P,EMICD
LOOPD1: SKIPN A,DONEFX+1;AND ANY R-TIME DONE FIXUPS?
JRST LOOPD2 ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
PUSHJ P,EMCD
LOOPD2: MOVE A,SAVSYM
POP P,DONEFX+1 ;RESTORE OLD FIXUP POINTERS
POP P,DONEFX
POPJ P, ;AND RETURN
; UNTIL statement
;
;<Until Statement> ::= DO <statement> UNTIL <condition>;
;
;Code Generated:
;G0001: <Statement>
; <Skip if condition true>
; JRST G0001
;
COMDO: DEBUG (UNTIL statement)
PUSH P,DONEFX ;SAVE DONE FIXUPS
PUSH P,DONEFX+1
SETZM DONEFX
SETZM DONEFX+1
PUSH P,RLOC ;SAVE FOR APPROPRIATE FIXUP
PUSH P,ILOC
PUSHJ P,SSTAT ;COMPILE A STATEMENT
PUSH P,IONLY ;SAVE STATE OF I-ONLY FLAG
CAME A,UNTILV ;BETTER BE AN 'UNTIL`
WARN (Missing 'UNTIL')
COMMENT ⊗ UNTIL missing from DO ... UNTIL statement or extraneous ';`.⊗;
SKIPN H
SETOM IONLY ;SET THE I-TIME ONLY FLAG
PUSHJ P,SLEXPR ;COMPILE A LOGICAL EXPRESSION WHICH SKIPS ON TRUE
EXCH A,(P) ;SAVE SYMBOL AND GET RLOC
SKIPN H
SKIPE IONLY
SKIPA
ERROR <Can't have an R-time statement controlled by an I-time conditional>
COMMENT ⊗ The DO ... UNTIL statement will never terminate under such circumstances. ⊗;
POP P,IONLY
POP P,B
SKIPE H ;IS IT R-TIME
MOVE B,A ;YES, USE R-TIME LOC
SETZ A,
MOVSI C,(<JRST>);EMIT JUMP BACK TO STATEMENT
PUSHJ P,EMINST
POP P,SAVSYM
JRST LOOPDN ;RESTORE SCANNED SYMBOL AND RETURN
; FOR Statement
;
;<for statement> ::= FOR <variable>←<expression> STEP <expression> UNTIL
; <expression> DO <statement>
;
;CODE GENERATED:
; MOVE A,<initial expression> ;MAY BE AN AC OTHER THAN 'A`
; JRST G0001 ;SKIP OVER INCREMENT
;G0002: MOVE A,<increment expression>
; ADD A,<for variable> ;INCREMENT FOR VARIABLE
;G0001: CAMLE A,<terminal expression> ;FINISHED?
; JRST DONE ;YES
; MOVEM A,<for variable> ;STORE IS DONE AFTER COMPARE
; <statement> ;DO STATEMENT
; JRST G0002 ;GO GET NEXT VALUE
;DONE: ;FOR VARIABLE CONTAINS LAST
; ;VALUE BELOW TERMINAL VALUE
;
COMFOR: DEBUG (FOR statement)
PUSH P,DONEFX ;SAVE DONE FIXUPS
PUSH P,DONEFX+1
SETZM DONEFX
SETZM DONEFX+1
PUSHJ P,SCANV ;SCAN FOR VARIABLE
SKIPN A
ERROR <UNDEFINED IDENTIFIER>
COMMENT ⊗ An identifier was used before it was declared. ⊗;
TLNE A,VRBLBT ;IS IT A VARIABLE?
TLNE A,STRFLG ;And not a string
ERROR <Simple variable required here>
COMMENT ⊗ FOR loops expect a simple variable, i.e. not an array. ⊗;
PUSH OSP,A ;SAVE IT TWICE, ONCE FOR INCREMENT
PUSH OSP,A ;ONCE FOR STORE
PUSH P,IONLY ;SAVE OLD IONLY FLAG
TLNN A,RVBT ;R-TINE VARIABLE?
SETOM IONLY ;NO, SET IONLY FLAG
PUSHJ P,SCAN ;GET '←'
CAME A,LARV ;BETTER BE
WARN <Missing '←' in FOR>
PUSHJ P,SEXPR ;COMPILE INITIAL EXPRESSION
PUSH P,A ;SAVE SYMBOL
PUSHJ P,SRTIMI ;SET R-TIME FLAG IF NEEDED
PUSHJ P,GMURK1 ;GMURK THE INITIAL EXPRESSION
SETZ A,
MOVE B,E
MOVSI C,(<MOVE>)
PUSH P,ILOC(H) ;EMIT A MOVE INTO AC TO BE DECIDED
PUSHJ P,EMINST ;UPON LATER
SETZB A,B
MOVSI C,(<JRST>);EMIT JRST AROUND INCREMENTING PART
PUSHJ P,EMINST
POP P,A ;GET BACK SAVED SYMBOL
EXCH A,(P)
CAMN A,UNTILV
JRST [ PUSH OSP,[XWD FLTFLG,[1.0]]
JRST CFOR1 ]
CAME A,STEPV ;SHOULD BE A 'STEP'
WARN <Missing 'STEP' in FOR>
PUSHJ P,SEXPR ;COMPILE INCREMENTING EXPRESSION
CAME A,UNTILV ;MAKE SURE IT'S FOLLOWED BY 'UNTIL'
WARN <Missing 'UNTIL' in FOR>
CFOR1:
MOVE A,(OSP)
MOVEM A,INCSYM#
PUSHJ P,ADDGEN ;DO INCREMENTING
MOVE A,(P) ;DO A FIXUP OF AC FOR FOREMENTIONED MOVE
TLO A,400000 ;INDICATE TO USE NEXT WORD FOR FIXUP
MOVEI B,.FXBTS
PUSHJ P,@EMITB2(H);EMIT FIXUP TO MOVE INSTRUCTION FORM PROPER AC
HRLZ A,(OSP) ;GET AC INTO PROPER PLACE IN INSTRUCTION
LSH A,5
SETZ B,
PUSHJ P,@EMITB2(H);EMIT 2ND WORD OF FIXUP
AOS A,(P) ;GET NEXT LOCATION IN CODE FOR JRST TO SKIP
MOVEI B,.FXBTS ;INCREMENT
PUSHJ P,@EMITB2(H);FIX THAT ONE UP, TOO
MOVE T,(OSP)
PUSHJ P,GPMARK ;DON'T USE AC CONTAINING VARIABLE!
PUSHJ P,SEXPR ;COMPILE FINAL EXPRESSION
CAMN A,DOV ;BETTER BE A 'DO`
JRST [ PUSHJ P,SCAN
JRST .+2 ]
WARN (Missing 'DO' in FOR)
PUSH P,A ;SAVE FIRST SYMBOL OF NEXT STATEMENT
PUSHJ P,SRTIMI ;SET R-TIME IF NEEDED
PUSH OSP,-1(OSP);COPY AC CONTAINING VALUE TO ASSIGN
MOVE A,INCSYM ;PICK UP INCREMENT VALUE
TLNE A,NUMFLG ;IS IT A CONSTANT
TLNE A,SUBSBT
JRST CFOR2
SKIPGE (A) ;IS IT NEGATIVE?
SKIPA A,GTV ;YES, DO OPPOSITE FLAVOR OF COMPARE
CFOR2: MOVEI A,LOP ;END TEST FOR LESS THAN OR EQUAL
PUSH P,[XWD 4000,0] ;PUSH MAGIC SKIP COMPLIMENT BIT
PUSHJ P,(A) ;EMIT END TEST
POP P,(P) ;FLUSH MAGIC SKIP COMPLIMENT BIT
SETZ A, ;EMIT A JRST TO END OF STATEMENT TO BE FIXED
MOVE B,ILOC(H) ;THIS IS THE SAME AS A DONE STATEMENT!
EXCH B,DONEFX(H)
MOVSI C,(<JRST>);UP LATER
PUSHJ P,EMINST
PUSHJ P,ASNGEN ;NOW STORE THE NEW VALUE OF FOR VARIABLE
POP P,A ;RESTORE SYMBOL
PUSHJ P,STAT ;COMPILE THE STATEMENT
MOVEM A,SAVSYM ;SAVE TERMINATOR
PUSHJ P,SRTIMI ;SET R-TIME IF NEEDED
SETZ A,
AOS B,(P) ;EMIT JRST BACK TO INCREMENT PART
MOVSI C,(<JRST>)
PUSHJ P,EMINST
POP P,(P) ;POP JUNK OFF STACK
POP P,IONLY ;NOW RESTORE I-TIME ONLY FLAG
JRST LOOPDN ;HANDLE DONE STATEMENTS
SRTIMIF:SKIPN IONLY ;SET R-TIME FLAG IF NEEDED
MOVEI H,1
POPJ P,
SUBTTL Recursive Expression Analyzer.
;THIS HERE IS THE COMPILER !
;<EXPR> ::= <EXPR2>!<EXPR2><LOGOP><EXPR2>
SEXPR: PUSHJ P,SCAN
EXPR: PUSH P,LOGFLG ;SAVE STATE OF LOGFLG
SETOM LOGFLG ;LET SCANNER SEE '<` AS OPERATOR
PUSHJ P,EXPR2
POP P,LOGFLG ;RESTORE STATE OF LOGFLG
TLNE A,DF ;A DELIMITER?
TLNN A,RELBIT+LOGBIT ;A LOGICAL ONE AT THAT?
POPJ P, ;NO, RETURN
PUSH P,[EXPR8] ;FAKE RETURN ADDRESS
PUSH P,LOGFLG
SETOM LOGFLG
PUSH P,[0] ;MAGIC SKIP COMPLIMENT BIT IS OFF
PUSH P,[LEXPR2] ;ANOTHER FAKE RETURN ADDRESS
JRST RELEX2 ;TO CALL LEXPR AFTER SCANNING AN EXPR2
EXPR8: PUSH P,A ;SAVE SCANNED SYMBOL
PUSHJ P,LXPGEN ;CONVERT A SKIP CONDITION INTO A NUMBER
JRST POPAJ ;RECOVER SAVED SYMBOL AND RETURN
SCLEXPR: PUSHJ P,SCAN ;SCAN FIRST
CLEXPR: PUSH P,LOGFLG ;SAVE STATE OF LOGFLG
SETOM LOGFLG ;LET SCANNER SEE '<` AS OPERATOR
PUSH P,[XWD 4000,0] ;PUSH MAGIC SKIP COMPLIMENT BIT
JRST LEXPR1
SLEXPR: PUSHJ P,SCAN ;SCAN FIRST
LEXPR: PUSH P,LOGFLG ;SAVE STATE OF LOGFLG
SETOM LOGFLG ;LET SCANNER SEE '<` AS OPERATOR
PUSH P,[0] ;PUSH A ZERO INSTEAD OF MAGIC COMPLIMENT BIT
LEXPR1: PUSHJ P,RELEXPR ;PARTIALLY COMPILE RELATIONAL
LEXPR2: TLNE A,DF ;A DELIMITER NEXT?
TLNN A,LOGBIT ;AND IS IT A LOGICAL OPERATOR?
JRST .+2 ;NO
JRST (A) ;CALL APPROPRIATE GENERATOR
EXCH A,-1(P) ;NEITHER, COMPILE IT STRAIGHT, GET MAGIC COMPLIMENT
;BIT AND SAVE SCANNED SYMBOL
EXCH A,(P) ;SAVE MAGIC COMPLIMENT SYMBOL AND GET OPERATOR
PUSHJ P,(A) ;CALL GENERATOR AND RETURN
POP P,(P) ;FLUSH MAGIC COMPLIMENT BIT
POP P,A ;RESTORE SAVED SYMBOL
POP P,LOGFLG ;RESTORE STATE OF LOGFLG
POPJ P,
SRELEXP: PUSHJ P,SCAN
RELEXP: PUSHJ P,EXPR2 ;GET FIRST HALF
TLNE A,DF ;A DELIMITER NEXT?
RELEX2: TLNN A,RELBIT ;AND IS IT A RELATIONAL OPERATOR?
JRST RELEX9 ;NO, TREAT IT AS <expr>≠0
EXCH A,(P) ;SAVE TERMINATOR UNDER RETURN ADDRESS
PUSH P,A
PUSHJ P,SEXPR2 ;COMPILE SECOND EXPRESSION
TLNE A,DF
TLNN A,RELBIT ;NEXT A RELATIONAL OPERATION?
POPJ P, ;RETURN
ERROR (Use of two relational operator is illegal here)
COMMENT ⊗ The compiler doesn't know how to deal with expression like
'2>X>9'. Write it as two conditions. ⊗;
RELEX9: PUSH P,A ;SAVE TERMINATOR
MOVE A,NEQV
EXCH A,-1(P) ;SAVE '≠` UNDER WHERE RETURN ADDRESS WILL BE
EXCH A,(P) ;AND GET TERMINATOR
PUSH OSP,[[XWD FLTFLG,$.+1
0]-1] ;PUSH A ZERO ONTO OPERAND STACK
POPJ P, ;RETURN
;<EXPR> ::= <TERM> ! <TERM><ADDOP><EXPR>
SEXPR2: PUSHJ P,SCAN
EXPR2: DEBUG (EXPR)
PUSHJ P,TERM
EXPR1: TLNE A,DF ;A DELIMITER NEXT ?
TLNN A,ADDBIT ;YES. AN ADD OR SUBTRACT OP. ?
POPJ P, ;NO.
PUSH P,A ;YES. LOOK FOR ANOTHER TERM.
PUSHJ P,STERM ;THIS IS ITERATIVE INSTEAD OF
; RECURSIVE IN ORDER TO PROCESS FROM LEFT TO
EXCH A,(P) ; RIGHT.
PUSHJ P,(A) ;CALL APPROPRIATE GENERATOR.
POP P,A
JRST EXPR1
;<TERM> ::= <FACTOR>!<FACTOR><MULOP><FACTOR>
STERM: PUSHJ P,SCANV
TERM: PUSHJ P,FACTOR
TERM1: TLNE A,DF ;A DELIMITER NEXT ?
TLNN A,MULBIT ;YES. A MULTIPLY OR DIVIDE OP ?
POPJ P, ;NO.
PUSH P,A
PUSHJ P,SFACTOR
EXCH A,(P)
PUSHJ P,(A)
POP P,A
JRST TERM1
SFACTOR:PUSHJ P,SCANV
FACTOR: JRST PRIMARY ;GOOD ENOUGH FOR NOW ...
; Primarys
;<primary> ::= -<primary>|(<expr>)|<array>(<expr>)|<function call>|
; <unit generator call>|<variable>|<constant>
SPRIM: PUSHJ P,SCAN
PRIMARY: JUMPE A,UDIERR ;STILL UNDEFINED ?
TLNN A,DF ;IS IT A SPECIAL CHAR. ?
JRST PRIM3 ;NO.
PRIM2: CAMN A,MINV ;UNARY MINUS ?
JRST [ PUSHJ P,SPRIM ;YES, SCAN A PRIMARY.
PUSH P,A
PUSHJ P,UMGEN ;CALL GENERATOR.
JRST POPAJ] ;RESTORE A AND RETURN.
CAME A,LPARV ;NO. IT BETTER BE A (.
ERROR (Illegal primary)
PRIM4: PUSHJ P,SEXPR ;SCAN AN EXPRESSION.
CAME A,RPARV ;LOOK FOR MATCHING PAREN.
WARNSK <Missing ')' in expression>
COMMENT ⊗ Unbalanced parentheses or missing operator in expression. ⊗;
JRST SCAN ;SCAN AND RETURN.
POPJ P,
PRIM3: TLNE A,FUNBIT ;THE NAME OF A FUNCTION ?
JRST [ PUSHJ P,FUNCAL ;COMPILE THE FUNCTION CALL.
PUSHJ P,MRKAC0 ;MARK AC0 FULL (VALUE OF FUNCTION).
;I QUESTION THE ABOVE LINE OF CODE, SHOULDN'T BE PUSHJ P,MRKAC (SEE FNOPR+1)
JRST SCAN] ;RETURN.
TLNE A,UGBIT ;THE NAME OF A UNIT GENERATOR?
JRST [ TRNN FL,INSDEF
ERROR <Unit generator call illegal outside of instrument definition>
COMMENT ⊗ Unit generators are only to be used inside of instruments as they require
special initialization at I-time. ⊗;
PUSH P,UGEXPF ;SAVE STATE OF FLAG TO INDICATE WE WANT A VALUE
SETOM UGEXPF ;FROM THIS UNIT GENERATOR
PUSHJ P,UGCALL ;COMPILE CALL ON UNIT GENERATOR
POP P,UGEXPF ;RESTORE STATE OF FLAG
PUSHJ P,MRKAC ;MAKE AC1 FULL (VALUE OF FUNCTION)
JRST SCAN] ;YES, CALL IT
SVRBL: TLNN A,VRBLBT!SWVBT!NUMFLG!FOOBIT ;SHOULD BE A VARIABLE,ARRAY NAME
ERROR <Illegal primary> ;NUMBER OR FOO SYM.
COMMENT ⊗ Should be a number, variable, array or function call. ⊗;
TLNE A,VRBLBT!NUMFLG!FOOBIT ;IS IT AN ARRAY NAME ?
JRST SVRBL2 ;NO.
; HRR A,(A) ;YES. GET R. HALF OF GOOD BITS.
; SUBI A,2 ;MAKE IT POINT TO ARRAY[-2].
PUSH OSP,A ;STASH THE ARRAY NAME
PUSHJ P,SCAN ;CHECK FOR LELAND'S CROCKISH Pn←<array name>;
CAMN A,SEMICV
JRST [ LELAN0: ;YES, THAT'S LELAND'S
PUSH OSP,A ;SAVE TERMINATOR
HRRZ A,-4(P) ;MAKE SURE IT'S AN ASSIGNMENT STATEMENT!
CAIE A,LELAN1 ;WAS IT CALLED FROM ASTMT1?
JRST LELAN2 ;NO. PRINT MISSING '('...
MOVE A,-1(OSP) ;YEP, GET ARRAY NAME BACK
HRR A,(A) ;YES. GET R. HALF OF GOOD BITS.
SUBI A,2 ;MAKE IT POINT TO ARRAY[-2].
MOVEM A,-1(OSP) ;SAVE IT ON STACK
POP OSP,A ;RETURN
POPJ P,]
PUSHJ P,CSUBSC ;COMPILE SUBSCRIPT
JRST SVRBL1 ;DON'T CHECK FOR NUMBERS
SVRBL2: SKIPE IONLY ;TURN OFF R-TIME FLAG IF WE'RE JUST GENERATING I-TIME
TLZ A,RVBT ;CODE.
PUSH OSP,A ;MAY BE AN ASN. STMT....
TLNE A,NUMFLG ;IF IT IS A NUMBER, IT CAN'T BE LEFT
JRST SCAN ;PART OF ASN. STMT.
SVRBL1: PUSHJ P,SCAN ;GET LEFT ARROW,IF ANY.
CAME A,LARV ;IT IS ONE, ISN'T IT ?
POPJ P, ;NOPE. JUST A GARDEN VARIETY VARIABLE.
PUSHJ P,ASTMT1 ;YES. COMPILE IT.
PUSHJ P,MRKAC ;SINCE IT'S A PRIMARY, REMEMBER ITS
JRST POPAJ ;VALUE, THEN RETURN.
ASTMT1: ;COMPILE ASSIGNMENT STMT...
PUSHJ P,SCAN ;Read a symbol to check for a string
TLNE A,STRFLG ;If it's a string, don't try to compile a expression!
JRST [ PUSH OSP,A
PUSHJ P,SCAN
JRST LELAN1 ]
PUSHJ P,EXPR ;COMPILE RIGHT PART OF STMT.
LELAN1: ;THIS IS THE RETURN ADDRESS WHICH MUST BE CHECKED
;TO PERMIT Pn←<array name> (SEE
EXCH A,(P) ;SAVE 'A' UNDERNEATH RETURN ADR.
PUSH P,A
JRST ASNGEN ;GENERATE THE STORE.
; Compile a Subscript for Array Reference
SCSUBS: PUSHJ P,SCAN
CSUBSC: CAMN A,LFTBRK ;SHOULD BE A '['
JRST .+3
CAME A,LPARV ;ACCEPT A "("
LELAN2: WARN <Missing '(' after array>
COMMENT ⊗ You are probably trying to use a array as a variable. Arrays must be
subscripted. ⊗;
PUSH P,NOTAC0 ;DON'T USE AC0!
SETOM NOTAC0
PUSHJ P,SEXPR ;COMPILE THE SUBSCRIPT
POP P,NOTAC0 ;OK NOW
CAMN A,COMMAV
ERROR <Multiply dimensioned arrays not implemented>
COMMENT ⊗ You may also have confused an array name with a function name. ⊗;
CAMN A,RGTBRK ;ACCEPT A ']'
JRST .+3
CAME A,RPARV
WARN <Missing ')' after array subscript>
MOVSI A,SUBSBT ;TURN ON THE SUBSCRIPT BIT IN STACK
HRRZ T,OSP
TDNE A,(T) ;IS TOP OF STACK A SUBSCRIPT?
SOJA T,.-1 ;SEARCH FOR ONE WHICH ISN'T!
CAIG T,OSTK ;BETTER NOT BE BELOW SECOND STACK ELEMENT
PUSHJ P,DRYROT ;OOPS!
ORB A,(T)
TLNE A,.FXBTS+LFXBTS
JRST NSTRSB
TLNE A,STRFLG ;Better not be a string!!!
ERROR <You can't subscript an array with a string!>
COMMENT ⊗ An array can only be subscripted by something that evaluates to
be a number. ⊗;
NSTRSB: CAIN T,(OSP) ;IF NOT TOP OR
TLNN A,SIACBT+SRACBT ;NOT AN AC THEN RETURN
POPJ P,
POP OSP,A ;GET AC OFF THE STACK AND MARK IT
JRST MRKAC ;IN AC TABLE
SUBTTL Compile a Function Call.
;<Function calls> ::= <identifier>(<parameter list>)
;<parameter list> ::= <parameter>,<parameter list>|<parameter>|
;<parameter> ::= <expression>|<array>
FUNCAL: DEBUG (FUNC. CALL)
FUNCA2: PUSH P,RLOC ;SAVE R-TIME CODE LOC. CTR.
HRRZ B,(A) ;GET PTR. TO PARAMETER DESCRIPTORS.
PUSH P,B ;PTR. TO SYMBOL TABLE ENTRY.
PUSH OSP,(B) ;PLACE CALLING INSTR. ON OPND. STK.
PUSH P,[POINT 6,0,35] ;MAKE A PTR. TO THE BYTES
HRRM B,(P) ; OF THE PARAMETER DESRIPTION.
ILDB T,(P) ;GET PARAMTER COUNT.
PUSH P,T
JUMPE T,FNOPR ;IF NO PARAMS., CALL GENERATOR.
PUSHJ P,SCAN ;SWALLOW LEFT PAREN.
CAMN A,LFTBRK ;OR LEFT BRACKET
JRST FUNC2A
CAME A,LPARV ;I HATE PEOPLE WHO DO THIS.
SKWARN <Missing '(' in function call> ;THAT'S BETTER
JRST FUNC4 ;IN THE ERROR CASE
FUNC2A: PUSHJ P,SCAN ;SCAN FIRST PARAM.
FUNC4: PUSH P,A
FUNC1: ILDB T,-2(P) ;GET NEXT PARAM. DESCRIPTOR.
CAIN T,ZTMPPAR ;IS IT A DUMMY PARAMETER. ?
JRST [ PUSHJ P,GDPAR ;YES, GENERATE A ZEROED DUMMY PARAM.
JRST FUNC1]
CAIN T,TMPPAR ;OR A TYPE 2 DUMMY ?
JRST [ PUSH OSP,[0] ;YES, EMIT A DUMMY PARAM., BUT WITHOUT
JRST FUNC1] ;ANY INSTR. TO ZERO IT AT I-TIME.
POP P,A ;NO.
JUMPE T,FLPAR ;IF =0,NO MORE PARAMS.
CAME A,RPARV ;NO PARENTHESES OR COMMAS HERE, PLEASE.
CAMN A,COMMAV
ERROR (Too few arguments in function call)
CAIN T,ARRPAR ;MUST THIS PARAM. BE AN ARRAY NAME ?
JRST [FUNC1T: ;YES, PARAMETER IS NAME OF ARRAY.
PUSHJ P,GAPAR ;CALL GENERATOR.
PUSHJ P,SCAN ;GET TERMINATOR
JRST FUNC2]
CAIN T,INTPAR ;IS IT TO BE AN INTEGER ?
JRST [ PUSHJ P,EXPR ;YES, CALCULATE EXPRESSION
PUSH P,A ;SAVE TERMINATOR
PUSHJ P,FIXGEN ;CONVERT TO INTEGER IF NECESSARY
POP P,A ;RESTORE TERMINATOR
JRST FUNC2] ;GET NEXT
CAIN T,STRPAR ;MUST THIS PARAM. BE A STRING CONSTANT?
JRST [ TLNN A,STRFLG ;YES, CHECK IT, AND CLEAR IT AS IT IS AN INDEX
ERROR (STRING REQUIRED HERE)
COMMENT ⊗ Something other than a string found as an argument to a function
which expected a string as (one of) its arguments. ⊗;
FUNC1S: PUSHJ P,GSPAR ;CALL GENERATOR
PUSHJ P,SCAN ;GET TERMINATOR
JRST FUNC2]
CAIN T,STAPAR
JRST [ ;SPECIAL HACK SO 'LENGTH' ACCEPTS STRING!!!
TLNN A,STRFLG
JRST FUNC1T ;NOT A STRING, USE ARRAY
SOS B,-2(P)
MOVE B,(B) ;CALL FOR STRING PRECEDES CALL FOR ARRAY
MOVEM B,(OSP)
JRST FUNC1S ]
TLNE A,STRFLG ;A string?
ERROR(NUMERIC ARGUMENT REQUIRED HERE)
COMMENT ⊗ A string was found where a numberic argument was expected. ⊗;
PUSHJ P,EXPR ;NO, LET IT BE AN EXPRESSION.
FUNC2: CAMN A,COMMAV ;IS IT A COMMA ?
FUNC3: PUSHJ P,SCAN ;YES, ALTHOUGH WE DONT REALLY CARE.
JRST FUNC4
FLPAR: CAMN A,COMMAV
SKWARN <Too many parameters in function call>
JRST [FLPAR1: PUSHJ P,SCAN ;LET'S ASSUME LOSER PUT IN ONE TOO MANY
TLNN A,DF ;IS IT A DELIMITER?
JRST FLPAR1 ;NO, TRY ANOTHER
JRST FLPAR2] ;YES, HOPE IT'S A ')'
FLPAR2: CAMN A,RGTBRK ;LAST PARAM. IS FOLLOWED BY EITHER ')' OR ']'
JRST FNOPR
CAME A,RPARV
WARN <Missing ')' or too many parameters in function call> ; ... OR ELSE.
FNOPR: PUSHJ P,GFUNC ;CALL GENERATORS.
ILDB A,-1(P) ;GET NO. OF AC CONTAINING RESULT.
HLL A,MRKTAB(H) ;GET SOME GOODBITS
SUB P,[XWD 4,4] ;FORGET ABOUT THINGS IN STACK.
POPJ P,
SUBTTL Code Generators
; HERE ARE THE GLORIOUS, SUPER-INTELLIGENT, SCHIZOPHRENIC
; CODE GENERATORS. LOOK UPON THEM AND BE AMAZED.
MULGEN: SKIPA T,[FMPR] ;GENERATE A MULTIPLY.
ADDGEN: MOVSI T,(<FADR>);SEE THE STUPID FAIL !
PUSH P,T
PUSHJ P,NUMCHK ;CHECK FOR BOTH BEING CONSTANTS
PUSHJ P,GGET1 ;GET ONE OPERAND IN AN AC.
GEN1: POP P,C ;RECOVER THE OPCODE.
GEN2: TLNN B,FLTFLG ;IS IT A FLOATING POINT NUMBER?
JRST GEN2A ;NO
TLNE B,17 ;IS IT RELOCATED?
JRST GEN2A ;%$$%&%# D. POOLE (SEE SNUMNO)! WE CAN'T OPTIMIZE!
HRRZ T,(B) ;GET THE RIGHT HALF OF ITS VALUE
JUMPN T,GEN2A ;IF IT'S ZERO, WE CAN MAKE AN IMMEDIATE
ADD C,[XWD 1000,0];INSTRUCTION OUT OF IT
HLRZ B,(B) ;GET VALUE (RELOCATIONS BITS = 0)
GEN2A: PUSHJ P,EMINST ;EMIT THE INSTRUCTION.
PUSHJ P,MRKAC ;MARK THE AC FULL
POPJ P,
DIVGEN: SKIPA T,[FDVR] ;GENERATE A DIVIDE ...
SUBGEN: MOVSI T,(<FSBR>); .. OR A SUBTRACT.
PUSH P,T
PUSHJ P,NUMCHK ;CHECK FOR BOTH BEING CONSTANTS
PUSHJ P,GGET2 ;GET FIRST OPERAND IN AN AC.
JRST GEN1
UMGEN: PUSHJ P,GMURK1
PUSH P,[MOVN]
PUSHJ P,NUMCH1 ;CHECK FOR CONSTANTS
PUSH P,E
PUSHJ P,GETAC ;GET A FREE AC.
POP P,B ;BRING BACK AC ADDRESS.
; MOVSI C,(<MOVN>);EMIT GOOD INSTRUCTION.
POP P,C ;RECOVER OPCODE
JRST GEN2A
FIXGEN:
PUSH P,[KIFIX]
PUSHJ P,GMURKA ;CHECK FOR CONSTANTS
TLNE E,FIXFLG ;IS IT ALREADY FIXED?
JRST [ POP P,(P) ;YES, THROW OUT OPCODE
POPJ P,] ;YES, RETURN
PUSHJ P,NUMCH1 ;CHECK TO SEE IF IT'S A NUMBER AND DEAL WITH IT
PUSHJ P,GG2 ;GET IT INTO AC
POP P,C
MOVE B,A ;Same address as AC for KI10 (i.e. FIX X,X)
JRST GEN2A ;EMIT IT AND MARK ITS AC
LXPGEN: PUSHJ P,GETACN ;GET ANY AC EXCEPT AC0
MOVE B,A ;EMIT CODE TO CLEAR AC AND SKIP
MOVSI C,(<TDZA>);FOR THE FALSE CASE
PUSHJ P,EMINST
MOVEI B,(1.0) ;EMIT CODE TO LOAD 1.0 FOR TRUE CASE
MOVSI C,(<MOVSI>)
PUSHJ P,EMINST
JRST MRKAC ;MARK IT IN USE
LOP: CAIA (<CAML>) ;A TABLE OF OPCODE FOR RELATIONALS
EOP: CAIA (<CAME>) ;LOTS OF FAST NOPS
LEOP: CAIA (<CAMLE>)
GEOP: CAIA (<CAMGE>) ;CALLED WITH OPERATOR IN 'A'
NEOP: CAIA (<CAMN>)
GOP: JFCL (<CAMG>)
RELGEN: HRLZ A,(A) ;GET OPCODE
PUSH P,A ;SAVE IT
MOVE T,(OSP) ;Check first arg. for string
TLNN T,.FXBTS+LFXBTS ;Relocatable
TLNN T,STRFLG ;or not string?
JRST RELGN2
JRST RELGER
RELGN2: MOVE T,-1(OSP) ;Check second argument
TLNN T,.FXBTS+LFXBTS ;Relocatable?
TLNN T,STRFLG ;and not string
JRST RELGN3
RELGER: ERROR <Attempt to do numeric operation on a string!>
COMMENT ⊗ String comparison not implemented. ⊗;
RELGN3: PUSHJ P,GGET1 ;GET ONE OF TOP TWO INTO AC
POP P,C
TDC C,-1(P) ;MAGIC SKIP COMPLIMENT BIT!
CAMN B,D ;DID GGET1 SWITCH OPERAND ORDER ON US?
JRST EMINST ;NO, WE CAN EMIT IT NOW
TLNN C,001000 ;IS IT <≤≥>?
JRST EMINST ;NO, LEAVE NOW
TLC C,007000 ;YES, CHANGE IT INTO THE REVERSED KIND OF COMPARE
ADD C,[XWD 1000,0]
JRST EMINST ;NOW WE CAN EMIT IT.
;WE COULD CHECK FOR AN OPERAND BEING A ZERO AND EMIT A SKIP--
;INSTEAD OF A CAM-- BY TURNING ON 20000 BIT IN OPCODE
ASNGEN: ;COMPILE STORE FOR ASIGNMENT STMT.
ASNOP: PUSH P,-1(OSP) ;SAVE PTR. TO GOOD BITS OF VRBL.
PUSHJ P,GMURK ;GET EXPR. AND LEFT-PART VARIABLE.
EXCH D,E ;GET THEM IN RIGHT ORDER.
TLNN D,ARRYBT ;A (numeric) array
TLZN D,STRFLG ;A string assignment? (STRFLG turned off for loader)
JRST [ TLNN E,ARRYBT ;A (numeric) array
TLNN E,STRFLG ;Or not a string?
JRST ASNGE2 ; Yes, OK
TLNE E,.FXBTS ;Better be a temporary
JRST ASNGE2 ; Yes, that's OK
ASNBAD: ERROR(Type mismatch for assignment)
COMMENT ⊗ You are trying to assign a string to a numeric variable or a number
to a string variable! ⊗;
]
TLNN E,ARRYBT ;Other better be a string
TLNN E,STRFLG
JRST ASNBAD ;Type mismatch
TLNE E,VRBLBT ;Variable?
TLZ E,STRFLG ; Yes, clear string flag (confuses loader)
ASNGE2: PUSHJ P,GG2 ;GET EXPR. IN AN AC.
POP P,T ;RECOVER PTR. TO VRBL. GOOD BITS WORD...
MOVSI C,(<MOVEM>) ;EMIT A MOVEM TO STORE VALUE OF EXPR.
JRST EMINST
ADDOP←←ADDGEN
SUBOP←←SUBGEN
MULOP←←MULGEN
DIVOP←←DIVGEN
ANDOP:
OROP: ERROR (Unimplimented operation)
COMMENT ⊗ AND and OR are not implimented. ⊗;
SUBTTL Emit code into code buffers
COMMENT ⊗
These routines put word + relocatation into code buffer. Their
function is determined by their name.
Emit Emit and Counter Word byte Reloc. byte
AOS counter pointer pointer
R-Time reloc. EMCD EMCDI RLOC EMPTR RELPTR
I-Time reloc. EMICD EMICDI ILOC EMIPTR RELIPTR
Variable reloc. EMVCD EMVCDI VLOC EMVPTR RELVPTR
Code is put into temporary buffers until the end of this compilation
when they are loaded by a special loader and then release.
⊗;
EMDV: SETZB A,B ;EMIT A DUMMY VARIABLE (TO RESERVE
; SPACE IN THE VARIABLES AREA).
EMVCDI: AOS VLOC
EMVCD: MOVEI T1,2 ;EMIT TO VARIABLE BUFFER.
JRST ECD
EMIABS: TDZA B,B ;EMIT TO I-TIME BUF. , NO RELOC.
EMCDI: AOSA RLOC ;SKIP INSTRUCTIONS WIN BIG.
EMICDI: AOSA ILOC ; SEE THE HAPPY INTERLEAVED CODE !
EMCD: TDZA T1,T1 ;EMIT TO RUNTIME BUFFER.
EMICD: MOVEI T1,1 ;EMIT TO INITIALIZE TIME BUFFER.
ECD:
IDPB A,EMPTR(T1) ;EMIT THE WORD.
MOVEM A,LSTWRD(T1) ;SAVE LAST WORD EMITTED
IDPB B,RELPTR(T1) ;ALSO ITS RELOCATION BITS.
AOSGE BUFCNT(T1) ;IS BUFFER FULL ?
POPJ P, ;NO. RETURN.
GBUF: ; BUFFER IS FULL; GET A NEW ONE.
MOVNI T,LOBUFS ;LENGTH OF A BUFFER.
PUSHJ P,GFS ;GET SOME FREE STORAGE(WHILE IT LASTS!)
HRLI T,400 ;MAKE BYTE PTR.
MOVEM T,RELPTR(T1) ;PTR. FOR RELOCATION BITS.
MOVEI T2,LOBUFS/12+2(T) ;LEAVE ROOM FOR REL. BITS
HRRM T2,EMPTR(T1) ;DATA PTR.
HRRZM T,@OBPTR(T1) ;FIX UP FORWARD LINKS.
HRRZM T,OBPTR(T1)
SETZM @OBPTR(T1)
MOVNI LOBUFS-LOBUFS/12-3
MOVEM BUFCNT(T1) ;SET UP WORD COUNT.
POPJ P,
EMPTR: POINT 36,0,35 ;DATA OUTPUT POINTERS FOR EACH KIND OF CODE
EMIPTR: POINT 36,0,35
EMVPTR: POINT 36,0,35
RELPTR: POINT 4,0 ;RELOC. BITS PTRS.
RELIPT: POINT 4,0
RELVPT: POINT 4,0
OBPTR: BLOCK 3 ;PTR. TO FIRST WORD OF CURRENT BUFFER FOR
; USE IN FIXING UP FORWARD LINKS.
BUFCNT: BLOCK 3 ;WORD COUNTS FOR BUFFERS.
FCBUF: 0 ;PTR. TO FIRST BUFFER IN EACH CHAIN FOR EACH KIND OF
FICBUF: 0 ;CODE
FVCBUF: 0
SUBTTL GPONDER - Examine top element of operand stack
; HA! I BET YOU THOUGHT WE WERE DONE, DIDN'T YOU ?
; WELL, HERE BEGINS AN INFINITE REGRESSION OF
; CLEVER ,GRUBBY ROUTINES WHICH DO THE
; DIRTY WORK FOR THE GENERATORS.
; GPONDER REMOVES THE TOP THING FROM THE OPERAND STACK,
; LOVINGLY PATS ITS MAGIC BITS INTO STANDARD FORMAT,
; AND SETS A FLAG INDICATING WHETHER IT IS AN
; R-TIME VARIABLE OR NOT.
GPONDER: MOVEI H,0 ;RESET R-TIME VARIABLE FLAG.
GPOND1: POP OSP,T ;GET TOP THING.
TLNE T,SUBSBT ;IS IT A SUBSCRIPT?
JRST GPSUBS ;YES, GENERATE AN ARRAY REFERENCE
SKIPN IONLY ;ARE WE GENERATING ONLY I-TIME CODE
JRST GPOND2 ;NO
TLNE T,SRACBT ;IS IT AN R-TIME AC?
PUSHJ P,DRYROT ;THIS SHOULD NOT HAPPEN!!
JRST GPOND3
GPOND2: TLNE T,SRACBT+RVBT ;AN R-TIME AC OR VARIABLE ?
MOVEI H,1 ;YES. SET R-TIME FLAG.
GPOND3: TLNE T,FOOBIT ;IS IT A FOO-SYMBOL?
JRST GPFOO ;YES.
TLNE T,NUMFLG ;A NUMBER ?
POPJ P, ;YES. WE ARE DONE.
TLNE T,SRACBT ;AN R-TIME AC ?
SETZM RACS(T) ;YES. MARK IT FREE.
TLNE T,SIACBT ;(SAME FOR I-TIME AC).
SETZM IACS(T) ;AC'S WILL ALSO BE PROTECTED AT GPMARK SO THEY
;THEY DON'T GET SWAPPED BEFOORE THEY'RE USED
TLNE T,ACFLAG ;IS IT AN AC?
JRST GPMARK ;YES, PROTECT IT
TLNE T,VRBLBT ;A VARIABLE ?
HRR T,(T) ;YES. GET RT. HALF GOOD BITS.
POPJ P,
;A FOO SYMBOL, MUST BE EITHER Pn OR Un
GPFOO: TRZE T,400000 ;IS IT A P-SYMBOL?
JRST GPONP ;YES.
;WE FOUND A Un
GPONU: SKIPE IONLY
WARN(Attempt to reference unit generator output at I-Time)
COMMENT ⊗ Unit generators output values at R-time, thus at I-time, the
output of a unit generator is undefined. ⊗;
MOVEI H,1 ;REFERS TO A UNIT GENERATOR; SET FLAG.
HRRZS T ;GET NO. OF UNIT GEN.
CAMLE T,UOPTR ;NO FORWARD REFERENCES TO UNIT GEN.
ERROR (Forward ref. to unit generator)
COMMENT ⊗ You have most likely referenced the output of a unit generator which
have not been defined yet. [If there are no Un symbols in the expression, it
may be a compiler bug.]⊗;
MOVE T,UOTBL(T) ;GET ADDRESS OF ITS OUTPUT CELL.
JRST GPFOO2
;WE FOUND A Pn
GPONP: HRRZ T,T ;Don't look at high order bits!!!
CAILE T,LPA ;Too big?
ERROR<Parameter number, Pn, too big>
COMMENT ⊗ The 'n' in 'Pn' is larger than the number of parameters allowed
for instrument calls. This number could be increased upon demand. ⊗;
ADDI T,PBASE ;BASE OF PARAM. ARRAY.
HRLI T,GPBIT ;MARK AS P-SYMBOL.
GPFOO2: TLNE T,SUBSBT ;CHECK FOR SUBSCRIPT
JRST GPSUBS
POPJ P,
;PROTECT AGAINST SWAPPING UNTIL IT SEES AN EMINST
GPMARK: MOVSI T1,NOSWAP ;PROTECT AN AC UNTIL AFTER IT IS USED IN AN EMINST
TLNE T,SRACBT ;AN R-TIME AC ?
JRST[ ORM T1,RACS(T) ;YES, PROTECT IT FREE.
POPJ P,]
TLNE T,SIACBT ;(SAME FOR I-TIME AC).
ORM T1,IACS(T)
POPJ P, ;RETURN
SUBTTL Array Reference Generation
; WE FOUND A SUBSCRIPT ON THE OPERAND STACK.
; WE MUST GET IT INTO AN APPROPRIATE AC, GET THE ARRAY
; POINTER AND MAKE SURE THAT AC DOESN'T GET SWAPPED OUT.
GPSUBS: HRRZ A,(P) ;DO WE HAVE TO LOOK AT SECOND OPERAND TO
CAIE A,GMURK+1 ;DETERMINE R-TIME OR I-TIME
JRST GPSUB1 ;NO, GOOD
MOVE A,-1(OSP) ;UGH, WE HAVE TO CHECKS ITS R-TIME TOO (ALSO -1(OSP) IS
;THE ARRAY POINTER)
TLNE A,SRACBT+RVBT ;TO DO SUBSRIPTING WITH CORRECT
MOVEI H,1 ;FLAVOR OF AC.
GPSUB1: MOVE A,(OSP) ;CHECK FOR F1[F1[I]]
TLNE A,SUBSBT
PUSH P,[GPSUB1] ;WE WANT TO COME BACK LATER IF NESTED ARRAY REFERENCES
MOVE E,T ;SET UP FOR REST OF GMURKING THE SUBSCRIPT
TLNE T,NUMFLG ;CONSTANT?
JRST GPSUB2 ;YES, RETURN VARIABLE INSTEAD OF INDEX ARRAY
TLZ T,SUBSBT ;TURN OFF SUBSCRIPT BIT
PUSH OSP,T ;PUT IT BACK ON STACK MINUS THE SUBSCRIPT BIT
PUSH P,NOTAC0
SETOM NOTAC0
PUSHJ P,GMURK1 ;GMURK IT! (ALSO DOES POP OSP,)
PUSHJ P,GG2 ;GET IT INTO AN APPROPRIATE AC
POP P,NOTAC0
MOVE B,A ;AC=ADR for KI10 FIX
MOVSI C,(<KIFIX>)
PUSHJ P,EMINST ;OUTPUT FIX INSTRUCTION FOR SUBSCRIPT
POP OSP,T ;GET POINTER TO GOODBITS WORD
TLNE T,FPARBT ;IS IT A FORMAL PARAMETER?
JRST GPSUB4 ;OH, WELL...
MOVEM T,ARRGBW# ;SAVE POINTER TO GOODBITS WORD
HRR T,(T) ;GET ADDRESS OF ARRAY
DPB A,[POINT 4,T,17] ;PUT INDEX IN RIGHT PLACE
SKIPE H ;DO NOT DO BOUNDS CHECKING FOR R-TIME CODE!
JRST [ TLO T,RVBT ;TURN ON R-TIME BIT
EXCH A,T ;GET AC INTO 'T'
SETZM RACS(T) ;Free AC after first use.
PUSHJ P,GPMARK ;MARK SUBSCRIPT AC IN USE
EXCH A,T ;GET THING TO RETURN BACK INTO 'A'
POPJ P,] ;RETURN
COMMENT ⊗
MOVE A,<subscript>
FIX A,233000
CAIGE A,<upper limit>
SKIPGE A
PUSHJ P,ILLARF ;%$%#&%$!!!
JUMP <symbol table pointer>
⊗;
PUSH P,T ;SAVE GOODBITS WORD TO BE RETURNED
MOVE B,-1(T) ;GET UPPER BOUND (USE -4(T) FOR SAIL)
MOVSI C,(<CAIGE>);(CAMG FOR SAIL)
PUSHJ P,EMINST ;EMIT CODE TO CHECK UPPER BOUND
PUSH P,A
MOVE B,A
SETZ A,
MOVSI C,(<SKIPGE>)
PUSHJ P,EMINST ;EMIT CODE TO CHECK LOWER BOUND
; MOVE B,-3(T)
; MOVSI C,(<CAMGE>)
; PUSHJ P,EMINST ;FOR SAIL
MOVE A,[PUSHJ P,ILLARF]
SETZ B,
PUSHJ P,EMICDI ;EMIT ERROR CALL
POP P,A ;GET AC OF SUBSCRIPT
HRRZ B,ARRGBW ;GET ARRAY GOODBITS WORD
MOVSI C,(<JUMP>)
PUSHJ P,EMINST ;EMIT POINTER TO GOODBITS (I HATE MYSELF FOR OUTPUT TWO
;WORD HERE. SHOULD BE DONE WITH UUO)
MOVE T,A
SETZM (A)
PUSHJ P,GPMARK ;MARK SUBSCRIPT AC IN USE
POP P,T ;WORDS, GET BACK GOODBITS WORD
POPJ P, ;PROTECT IT
;CONSTANT FOR SUBSCRIPT! WE CAN CALCULATE IT HERE AND TREAT AS IT IS JUST AN
;ORDINARY VARIABLE
GPSUB2: MOVE E,(E)
KIFIX E,E ;FIX SUBSCRIPT
POP OSP,T ;GET GOOD BITS WORD
TLNE T,FPARBT ;A FORMAL?
JRST GPSUB3
HRR T,(T) ;GET ADDRESS OF ARRAY
SKIPL E ;CHECK SUBSCRIPT
CAML E,-1(T) ;THIS WON'T WORK WITH SAIL
ERROR (Subscript out of bounds at compile time.)
COMMENT ⊗ You have a subscript expression which evaluates to a constant which
is either too large or too small. ⊗;
ADD T,E ;ADD SUBSCRIPT
TLZ T,ARRYBT
TLO T,VRBLBT ;MAKE IT LOOK LIKE A VARIABLE!!!
POPJ P, ;RETURN!
;AN ARRAY AS A FORMAL PARAMETER WITH CONSTANT SUBSCRIPT
;CODE GENERATED:
; HRRZ A,<PARAMETER NUMBER>(RA)
;LEAVES '<SUBSCRIPT>(A)' ON IN 'T'
;***** Bounds checking should be done on subscript! *****
GPSUB3: MOVE B,(T) ;GET GOODBITS
PUSH P,B ;SAVE B (CLOBBERED BY GETACN)
PUSHJ P,GETACN ;GET AN AC
POP P,B
MOVSI C,(<HRRZ>)
GPSUB5: HRLI B,ARRYBT+RA
PUSHJ P,EMINST
MOVE T,A ;Setup for GPMARK
JUMPN H,[SETZM RACS(T) ;Flush AC after use
JRST GPSUB6]
SETZM IACS(T)
GPSUB6: PUSHJ P,GPMARK ;MARK SUBSCRIPT AC IN USE
MOVSI T,ARRYBT ;GOOD ENOUGH...
HRR T,E
DPB A,[POINT 4,T,17] ;PUT INDEX IN RIGHT PLACE
POPJ P, ;RETURN
;AN ARRAY AS A FORMAL PARAMETER WITH NON-CONSTANT SUBSCRIPT
;CODE GENERATED:
; MOVE A,<SUBSCRIPT>
; FIX A,233000
; ADD A,<PARAMETER NUMBER>(RA)
;LEAVES '(A)' ON IN 'T'
;***** Bounds checking should be done on subscript! *****
GPSUB4: MOVE B,(T)
MOVSI C,(<ADD>)
SETZ E,
JRST GPSUB5 ;IT LOOKS RATHER SIMILAR TO CONSTANT CASE
;GET AN AC BUT NOT AC0
GETACN: PUSH P,NOTAC0
SETOM NOTAC0 ;DON'T USE AC0!
PUSHJ P,GETAC
POP P,NOTAC0
POPJ P,
SUBTTL GMURK - Set up top two elements of stack for code generation
; GMURK CLEVERLY GPONDERS THE TOP TWO OPERANDS,
; AND IF ONE OF THEM IS AN R-TIME VARIABLE
; AND THE OTHER IS AN I-TIME AC OR A P-SYMBOL, IT STORES
; THE LATTER WHERE IT WILL BE SAFE UNTIL R-TIME.
;
; RETURNS LEFT OPERAND IN D
; RETURNS RIGHT OPERAND IN E
;
; GMURKA AND GMURK1 ONLY GMURK THE TOP OPERAND AND LEAVE IT IN E,
; WITH D SET TO ZERO.
GMURKA: MOVEI H,0
GMURK1: TDZA T,T ;PROCESS ONLY TOP STACK ELEMENT.
GMURK: PUSHJ P,GPONDER ;GPONDER THE FIRST OPERAND.
PUSH P,T ;SAVE IT
PUSHJ P,GPOND1 ;NOW THE SECOND.
POP P,D ;PUT THEM BOTH IN SOME SAFE ACCUMULATORS.
MOVE E,T
GM1: SKIPN H ;IS EITHER ONE AN R-TIME VARIABLE ?
JRST ACSRCH ;NO, SEARCH AC'S TO SEE IF EITHER IS IN AN AC
TLNE E,SIACBT+GPBIT ;AN I-TIME AC OR A P-SYMBOL ?
JRST GM2 ;YES.
TLNN D,SIACBT+GPBIT ;HOW ABOUT THIS ONE ?
JRST ACSRCH ;HE ISN'T, EITHER. LOOK FOR BOTH IN R-TIME AC'S
SKIPA F,[EXP D] ;BAGBITING MACROX.
GM2: MOVEI F,E ;SEE THE TWO HEADED MONSTER.
MOVE A,(F) ;GET THE RELEVANT THING.
TLNE A,GPBIT ;A P-SYMBOL, OR AN I-TIME AC ?
JRST GM3 ; A P-SYMBOL.
MOVE B,VLOC ;AN I-TIME AC, STORE IT IN VARIABLE AREA.
GM3B: MOVEM B,(F) ;CHANGE THE OPERAND INDICATOR.
MOVE C,[MOVEM EMICDI] ;EMIT THE STORE INSTRUCTION.
PUSHJ P,EMINST
PUSHJ P,EMDV ;MAKE A PLACE IN THE VARIABLES FOR IT.
JRST ACSRCH ;SEE IF THE OTHER IS IN AN R-TIME AC
;A P-SYMBOL - WE BETTER NOT BE INTERPETING AS IT LOSES AS THERE ARE NUM-
;BERS WHERE WE EXPECT ADDRESSES IN THE P_ARRAY!!!
GM3: TRNN FL,INSDEF ;THIS SHOULD FIX ABOVE PROBLEM
JRST ACSRCH
SKIPN T1,(A) ;HAS THE PARAMETER ALREADY BEEN
JRST GM3A ; PUT IN VAR. AREA ?
MOVEM T1,(F) ;YES. CHANGE POINTER.
JRST ACSRCH ;SEARCH TO SEE IF OTHER IS IN AN R-TIME AC
GM3A: PUSHJ P,GETIAC ;FIND FREE I-TIME AC.
MOVE B,(F)
MOVE T,VLOC ;GET VAR. LOC. CTR.
TLO T,GPBIT
MOVEM T,(B) ;ENTER IN PARAMTER TABLE.
MOVE C,[MOVE EMICDI] ;EMIT INSTR. TO
PUSHJ P,EMINST ;PICK UP THE PARAMETER.
MOVE B,VLOC ;GET LOC. AGAIN...
TLO B,GPBIT ;MARK AS A P-SYMBOL.
JRST GM3B ;NOW STORE THE PARAMETER IN VAR. AREA.
ACSRCH: POPJ P,
; GGET - Gets one of top two stack elements into an AC.
; STILL MORE KLUGES. PAUSE TO GET YOUR BREATH NOW.
; GGET1 ARRANGES TO HAVE ONE OF THE TOP TWO OPERANDS
; IN AN AC.
; RETURNS IN 'A' THE ADDRESS OF THAT AC, AND
; THE ADDRESS OF THE OTHER OPERAND IN 'B', WITH RELOCATION
; BITS IN LEFT HALF.
; CLOBBERS 'C'
; ALSO RETURNS LEFT OPERAND IN 'D' AND
; RIGHT OPERAND IN 'E'
GGET1: PUSHJ P,GMURK ;PROCESS TOP TWO OPERANDS.
TLNN D,SIACBT+SRACBT ;IS FIRST ONE IN AN AC ?
JRST GG2 ;NO.
MOVE A,D ;YES. WE ARE DONE.
MOVE B,E
POPJ P,
GGET2: PUSHJ P,GMURK ;GGET2 GETS SECOND OPERAND IN AN AC.
GG2: MOVE A,E ;PUT OPERAND IN A.
TLNE A,SIACBT+SRACBT ;IS IT ALREADY IN AN AC ?
JRST [ TRNN A,17 ;YES, IS IT AC0?
SKIPN NOTAC0 ;AND WE PROHIBITED FROM USING AC0?
JRST GL2A ;NO. WIN BIG.
SETZ E ;OOPS, WE GET COPY AC0 INTO SOMEONE ELSE!!!
JRST GG2A] ;THIS IS MOST UNFORTUNATE AS WHEN IT GENERATES
;POOR CODE. AND WE DON'T KNOW WHO HE BELONGS TO!!
; TLNE D,SIACBT+SRACBT ;HOW ABOUT OTHER OP. ?
; SETOM @ACTB3(H) ;AN AC... MARK IT FULL TEMPORARILY.
;IT SHOULD ALREADY HAVE BEEN MARKED...
GG2A: PUSHJ P,GETAC ;GET A FREE AC OF THE APPROPRIATE KIND.
TLO E,NOSWAP ;DON'T ALLOW IN TO BE SWAPPED UNTIL IT HAS SEEN
;EMINST
MOVEM E,@ACTB1(H) ;TELL WORLD WHAT IT WILL CONTAIN
TLNE E,STRFLG ;Is it a string constant?
TLNE E,SWVBT+.FXBTS+LFXBTS ;Does it not have relocation bits?
JRST GG2B ;No, something else
TLNE E,VRBLBT ;Is it a variable?
JRST GG3 ;Yes, normal
MOVSI C,(<MOVEI>) ;String constants are special
HRRZ B,E
JRST GG4
GG2B: TLNN E,NUMFLG ;IS IT A CONSTANT?
JRST GG3 ;NO, EMIT A MOVE
HRRZ B,(E) ;IS RIGHT HALF ZERO?
JUMPE B,[MOVSI C,(<MOVSI>);YES, EMIT A MOVSI
MOVS B,(E) ;ADDRESS IS VALUE OF NUMBER
JRST GG4]
HLRZ B,(E) ;IS LEFT HALF ZERO?
JUMPE B,[MOVSI C,(<MOVEI>);YES, EMIT A MOVEI
MOVE B,(E) ;ADDRESS IS VALUE OF NUMBER
JRST GG4]
GG3: MOVE B,E ;LOAD SECOND OPERAND INTO IT.
MOVSI C,(<MOVE>)
GG4: PUSHJ P,EMINST
GL2A: MOVE B,D ;PUT OTHER OP IN B.
POPJ P,
; NUMCHK - Compile time arithmetic
; NUMCHK CHECKS TO SEE IF THE TOP TWO OPERANDS ARE BOTH CONSTANT
; AND CALCULATES THEIR VALUE AT COMPILE TIME
; IT ALSO CHECKS TO MAKE SURE BOTH THINGS ARE NUMBERS!
NUMCHK: MOVE T,(OSP) ;Check first arg. for string
TLNN T,.FXBTS+LFXBTS ;Relocatable
TLNN T,STRFLG ;or not string?
JRST NUMCH2
JRST NUMERR
NUMCH2: MOVE T,-1(OSP) ;Check second argument
TLNE T,.FXBTS+LFXBTS ;Relocatable?
POPJ P, ; Yes, can't be constants
TLNE T,STRFLG ;No, better not be a string
NUMERR: ERROR <Attempt to do numeric operation on a string!>
COMMENT ⊗ You have given a string to a numeric operator, such as '+', '-',
'*', '/', '>', etc. ⊗;
MOVSI T,NUMFLG ;ARE BOTH NUMBERS?
TDNE T,(OSP) ;TOP?
TDNN T,-1(OSP) ;AND SECOND?
POPJ P, ;NO
MOVSI T,SUBSBT ;IS SECOND A SUBSCRIPT?
TDNE T,-1(OSP)
POPJ P, ;YES, BARF
POP P,(P) ;YES, DISCARD RETURN ADDRESS FOR NUMCHK
POP P,T ;ASSEMBLE INSTRUCTION IN 'T'
ADD T,[C,@(OSP)]
MOVE C,@-1(OSP) ;GET FIRST OPERAND
XCT T ;DO OPERATION
POP OSP,(OSP) ;FLUSH TOP OPERAND ONLY
; FOR UNARY OPERATORS, ENTER HERE AFTER FINDING NUMBER AND DOING OPERATION
NUMCHC: HLL T,(OSP) ;USE TOP OPERAND'S (A NUMBER) GOODBITS
HLLZ A,T ;FOR STORE NUMBER SEARCHING ROUTINE
PUSHJ P,SRHNUM ;SEARCH NUMBER BUCKET AND INSERT IF NEEDED
MOVEM A,(OSP) ;PUT IN ON THE STACK
POPJ P, ;RETURN FROM GENERATOR WHICH CALLED THIS (IT BETTER
;NOT HAVE LEFT ANYTHING ON THE STACK!!)
NUMCH1: TLNE E,STRFLG ;Is it a string?
JRST NUMERR ;Yes, lose big
TLNE E,NUMFLG ;IS IT A NUMBER?
TLNE E,SUBSBT ;AND NOT A SUBSCRIPT
POPJ P, ;NO, GIVE UP
PUSH OSP,E ;PUT IT ON THE STACK
POP P,(P) ;DISCARD NUMCH1'S RETURN ADDRESS
POP P,T ;RECOVER OPCODE
MOVE C,(E) ;GET VALUE OF CONSTANT
TRNN T,-1 ;DO WE NEED AN ADDRESS?
HRRI T,C ;YES, POINT IT TO 'C'
ADD T,[C,0]
XCT T ;NOW EXECUTE IT
JRST NUMCHC ;AND STASH THE RESULT INTO NUMBER LIST
; EMINST - Emit an instruction.
;
; EMINST IS THE INSTRUCTION EMITTING ROUTINE. CALL IT
; WITH:
; AC IN A,
; ADDRESS (+ RELOC. BITS) IN B, AND
; OPCODE IN C.
;
; IF ARRYBT IS SET, THE INDEX FIELD OF B CONTAINS THE
; INDEX INSTEAD OF THE RELOCATION BITS
;
; IF RIGHT HALF OF C IS NON-ZERO, IT IS THE
; ADDRESS OF THE APPROPRIATE BUFFER EMITTING ROUTINE
; OTHERWISE THE INSTR. IS PLACED IN THE I-TIME OR R-TIME
; BUFFERS ACCORDING TO THE STATE OF THE FLAG IN H.
EMINST: PUSH P,A ;SAVE IT.
MOVSI T2,NOSWAP ;TO TURN OFF PROTECTED BIT
HLL A,C ;ASSEMBLE INSTRUCTION IN A.
DPB A,[POINT 4,A,12] ;PUT IN AC FIELD.
HRR A,B ;ALSO ADDRESS.
TLNE B,SIACBT ;IS IT AN I-TIME AC?
ANDCAM T2,IACS(B) ;UNMARK ITS AC TABLE ENTRY
TLNE B,SRACBT ;IS IT AN R-TIME AC?
ANDCAM T2,RACS(B) ;UNMARK ITS AC TABLE ENTRY
TLZE B,FPARBT ;IS ADDR. A FORMAL PARAMETER ?
TLO A,20+RA ;YES. ADD INDIRECT BIT AND INDEX.
TLNE B,ARRYBT ;IS ADDR. A ARRAY?
JRST [ DEBUG(EMIT ARRAY REF);
AND B,[(17)] ;GET INDEX FIELD
ADD A,B ;PUT IN INDEX FIELD
HLRZ T1,B
SKIPE T1
ANDCAM T2,@[ XWD T1,IACS ;IACS(T1)
XWD T1,RACS](H) ;RELEASE APPROPRIATE AC
SETZ B, ;SET RELOCATION TO ZERO
JRST EMIN1]
HLRZS B ;PUT RELOC. BITS FOR ADDRESS IN RIGHT HALF OF B.
EMIN1: PUSH P,[EXP EMIN2] ;RETURN ADDRESS.
TRNE C,-1 ;RH OF C =0 ?
JRST (C) ;NO.
JRST @EMITB(H)
EMIN2: LDB A,[POINT 4,A,12]
MOVSI T2,NOSWAP ;TO TURN OFF PROTECTED BIT IN AC TABLE
CAIG T1,1 ;IN CASE WE WERE EMITTING TO VARIABLE AREA
ANDCAM T2,@[XWD A,RACS ;RACS(A)
XWD A,IACS](T1) ;T1 IS 1-H REVERSED!(USUALLY)
POPAJ: POP P,A ;A USEFUL ENTRY POINT.
POPJ P,
EMITB: EMICDI
EMCDI
EMITB2: EMICD
EMCD
ACTB1: XWD SIACBT+A,IACS ;PTR. TO IACS,INDEXED BY A.
XWD SRACBT+A,RACS
ACTB3: XWD D,IACS
XWD D,RACS
; GETAC - Get a free AC.
;
; GETAC SEARCHES FOR A FREE AC, EITHER I-TIME OR
; R-TIME, AS INDICATED BY THE STATE OF THE FLAG IN H.
;
; Returns AC in A. Clobbers T,T3,A,B,C
GETAC: SKIPE H ;ARE WE EMITTING R-TIME CODE ?
GETRAC: SKIPA T3,[XWD SRACBT+A,RACS] ;YES, FIND A R-TIME AC.
GETIAC: MOVE T3,[XWD SIACBT+A,IACS] ;FIND AN I-TIME AC.
MOVE A,[XWD -NACS,NFACS] ;CONSIDER ONLY AC'S 4-14
TRNE FL,CSBRBT ; ..UNLESS WE'RE COMPILING A FUNCTION..
MOVE A,[XWD -NFACS,0] ;WE ARE. CONSIDER ONLY 0-3.
HRRZM A,LASTAC# ;SAVE WHICH IS LOWEST USABLE
SKIPE @T3 ;INDIRECT ADDRESSING IS GOOD FOR YOU.
AOBJN A,.-1 ;NOT FREE. TRY FOR NEXT ONE.
HRRZ B,A
SKIPE NOTAC0 ;CAN WE USE AC ZERO?
JUMPE B,.-3 ;NO, TRY AGAIN
JUMPLE A,GETAC3 ;DID WE FIND ONE ?
PUSHJ P,GETAC2 ;NO. STORE ONE.
GETAC3: HRLI A,SRACBT ;YES. PUT IN APPROPRIATE FLAG BITS.
TLNN T3,SRACBT ;OOPS, IT'S AN I-TIME AC.
HRLI A, SIACBT
POPJ P,
GETAC2: HRRZ A,A
SUBI A,1 ;STORE HIGHEST AC.
SKIPE NOTAC0 ;CAN WE USE AC ZERO?
JUMPE A,GETAC4 ;NO, WE LOSE!
SKIPL T,@T3 ;GET VALUE AND SKIP IF SPECIALLY MARKED
JRST GSVAC+1 ;OK, WE CAN SWAP HIM OUT WITHOUT ILL EFFECTS
CAMLE A,LASTAC
JRST GETAC2+1
;THERE NO FREE AC AT ALL
GETAC4: ERROR <EXPRESSION TOO COMPLEX, MAY BE A COMPILER BUG>
GSVAC: MOVE T,@T3 ;FIND OUT WHO'S IN HIM.
TLNN T,ACFLAG ;IS IT NECESSARY TO SAVE HIM?
JRST [ SETZM @T3 ;NO, JUST FLUSH HIM
POPJ P,]
TRNN T,777760 ;IS IT AN AC?
PUSHJ P,DRYROT ;OOPS!
;**** The random good bits in VLOC have STRFLG on!!! ****
MOVE B,VLOC ;GET LOC. TO STORE HIM IN.
TLNE T,SUBSBT ;IS HE A SUBSCRIPT?
TLO B,SUBSBT ;YES, HIS STACK ENTRY BETTER SAY THAT
MOVEM B,(T) ;FIX UP HIS STACK ENTRY.
SETZM @T3 ;MARK HIM EMPTY.
MOVSI C,(<MOVEM>) ;EMIT THE STORE INST.
PUSHJ P,EMINST
PUSH P,A ;'A' WAS CLOBBERED BY EMDV!!!!
PUSHJ P,EMDV ;LEAVE A PLACE IN VARIABLES AREA.
JRST POPAJ ;RESTORE 'A' AND RETURN
;MRKAC PUTS THE AC SYMBOL IN A BACK ON THE STACK AND MARKS
; THE CORRESPONDING AC AS FULL.
MRKAC0: IOR A,MRKTAB(H) ;MARK IAC 1 OR RAC 1 FULL.
MRKAC: PUSH OSP,A ;PUT IT ON STACK.
TLNN A,SRACBT ;AN R-TIME AC?
JRST [ HRRZM OSP,IACS(A) ;NO, MARK CORRESPONDING I-TIME AC FULL.
HLLM A,IACS(A)
JRST CPOPJ]
TLO A,SIACBT ;FORCE I-TIME AC BIT
HRRZM OSP, RACS(A)
HLLM A,RACS(A)
CPOPJ: POPJ P,
;CODE TO RELEASE USED AC'S
;[Gee, i wonder what happens if A is a VLOC reference - Dec76 (TVR)]
SWAPON: PUSH P,A ;SAVE A
MOVSI T3,400000
TRNN A,777760 ;IS IT AN AC?
ANDCAM T3,@ACTB1(H)
JRST EMIN2 ;DO IT FOR AC, TOO
MRKTAB: XWD SIACBT,0 ;DESCRIPTOR FOR I-TIME AC NO. 1
XWD SRACBT,0 ;R-TIME AC 1.
; Generate Function Calls;
GAPAR: ;; HANDLE A PARAMETER WHICH IS AN ARRAY NAME.
TLNE A,ARRYBT ;IS IT AN ARRAY IDENTIFIER OR
HRR A,(A)
TLNE A,FPARBT+ARRYBT ; A FORMAL PARAMETER ?
JRST GAPR1 ;YES.
TLNE A,FOOBIT ;BETTER BE A FOO-SYMBOL, THEN....
TRZN A,400000 ;FURTHERMORE, IT MUST BE A P-SYM.
ERROR <IMPROPER ARRAY PARAMETER>
;Code generated (in I-Time) for P-array as argument to function
; MOVE AC,PBASE+n
; CAMG AC,[XWD INSXR,777777]
; CAMG AC,[XWD INSXR,0]
; PUSHJ P,BADARR
; MOVEM AC,[calling seq.]
;
GSPA2: PUSH P,A ;SAVE P NO.
PUSHJ P,GETIAC ;FIND FREE I-TIME AC.
POP P,B
ADDI B,PBASE ;CALC. ADDR. OF P-SYMBOL.
MOVE C,[MOVE EMICDI] ;EMIT MOVE AC,P-SYMBOL TO THE
PUSHJ P,EMINST ;I-TIME CODE STREAM.
;Here is code to check to make sure its an array!
PUSH P,A ;Save AC
MOVEI B,[XWD INSXR+1,777777] ;Do bounds checking at I-time
MOVE C,[CAMG EMICDI] ;Emit CAMG AC,[777777(INSXR)]
PUSHJ P,EMINST
MOVEI B,[XWD INSXR,0] ;Do bounds checking at I-time
MOVE C,[CAMG EMICDI] ;Emit CAMG AC,[0(INSXR)]
PUSHJ P,EMINST
MOVE A,[PUSHJ P,BADARR]
SETZ B,
PUSHJ P,EMICDI ;EMIT ERROR CALL
POP P,A ;Restore AC
HRLI A,(<MOVEM>) ;NOW A MOVEM AC, INTO THE PARAMETER
DPB A,[POINT 4,A,12] ;LOCATION.
TRZA A,-1 ;CLEAR ADDRESS FIELD.
GDPAR: MOVSI A,(<SETZM>) ;PARAM. LIST AT I-TIME.
PUSH OSP,ILOC ;PUT ARRAY MARKER IN OPERAND
MOVSI T,ARRYBT+FPARBT ;STACK SO A FIXUP CAN BE EMITTED TO
IORM T,(OSP) ;THE UPCOMMING HRRM WHEN THE PARAMETERS
MOVEI B,0 ;[NO RELOCATION, PLEASE.]
JRST EMICDI ;EMIT HRRM TO STORE ARRAY LOC. INTO
;PARAMETER CELL, AND RETURN.
GAPR1: PUSH OSP,A ;PLACE IN OPERAND STACK.
TLNE A,FPARBT ;CHECK TO FIND BUGS, MAKE SURE FORMAL
TRNN FL,INSDEF ;PARAMETER AREN'T USED IN INSTRUMENTS!
POPJ P, ;OK, RETURN
PUSHJ P,DRYROT ;OOPS!
GSPAR: ;;HANDLE A PARAMETER WHICH IS A STRING
TLNE A,FPARBT!VRBLBT ;IS IT A FORMAL PARAMETER OR VARIABLE?
HRR A,(A) ;YES, GET NUMBER OF PARAMETER OR ADDRESS
TLNE A,VRBLBT ;Is it a string variable?
TLO A,20 ; Yes, turn on indirect bit
TLZE A,STRFLG ;IS IT A STRING?
JRST GAPR1
TLNE A,FOOBIT ;BETTER BE A FOO-SYMBOL
TRZN A,400000 ;AND A P-SYMBOL
ERROR <IMPROPER STRING PARAMETER>
JRST GSPA2 ;WILL THAT REALLY WORK???
; More Code Generator for Function Calls (GFUNC)
; (Rewritten 25 Sep 76 by TVR)
GFUNC: MOVE A,@-3(P) ;PICK UP THE CALLING INSTRUCTION FOR THE FUNCTION.
MOVE D,RLOC ;DECIDE WHETHER CALL IS TO BE IN
MOVEI H,0 ;R-TIME OR I-TIME CODE.
SKIPE IONLY ;ARE WE GENERATING I-TIME ONLY?
JRST GFUNC8 ;YES
TLZN A,20 ;IND. BIT IN INSTR. SAYS R-TIME ALWAYS.
CAME D,-4(P) ;ALSO R-TIME IF ANY R-TIME PARAMETERS
MOVEI H,1 ;HAVE BEEN COMPILED.
GFUNC8: PUSH P,-1(P) ;PUT PAR. COUNT ON STACK.
HRRZM P,TEMP1# ;SAVE LOC. OF COUNT.
GFUNC5: SOSGE @TEMP1 ;MORE PARAMS ?
JRST GFUNC4 ;NO.
PUSHJ P,GMURK1 ;GET A PARAM.
TLNE E,FPARBT ;IS IT A FORMAL PARAMETER ?
JRST GFUNC7 ;YES
TLNE E,ARRYBT ;IS IT AN ARRAY?
JRST GFUNC9 ;DO ARRAY REFERENCE
TLNE E,SRACBT+SIACBT ;Is it an AC?
JRST GFUN13 ; Yes, save it perhaps
;AN ORDINARY TYPE PARAMETER
GFUN11: PUSH P,E ;SAVE IT.
JRST GFUNC5 ;GET ANOTHER.
;An AC, make it so that AC will get saved!
GFUN13: PUSH P,E
TLNE E,SRACBT ;An R-time AC?
JRST [MOVEM E,ACS(E) ;Yes, make pointer into stack
HRRM P,ACS(E)
JRST GFUNC5]
MOVEM E,IACS(E) ;Must be an I-time AC
HRRM P,IACS(E)
JRST GFUNC5
;HANDLE AN ARRAY PARAMETER
GFUNC9: LDB A,[POINT 4,E,17] ;IS IT SUBSCRIPTED?
JUMPE A,GFUN11 ;NO, WE DON'T CALCULATE SUBSCRIPT
SETZ A, ;IT'S AN SUBSCRIPTED ARRAY, EMIT
MOVE B,E ;CODE TO GET ADDRESS REFERNCED
MOVSI C,(<MOVEI>)
PUSHJ P,EMINST
JRST GFUN10 ;AND PUT IT INTO CALLING SEQUENCE
;HANDLE A FORMAL PARAMETER
GFUNC7: TRNE FL,INSDEF ;IF THIS IS AN INSTRUMENT DEFINITION, IT REALLY
JRST GFUN12 ;MEANS WE WANT TO FIX UP A UNIT GENERATOR CALL!!!
MOVE A,E ;SIGH. THE PRICE OF HONESTY ...
HRLI A,(<MOVE (RA)>) ;EMIT CODE TO PICK UP THE
MOVEI B,0 ;PARAM. PTR. AND PUT IT IN THE
PUSHJ P,@EMITB(H) ;CURRENT CALLING SEQUENCE.
;PUT SOMETHING INTO CALLING SEQUENCE
GFUN10: MOVE E,ILOC(H) ;SAVE ILOC OR RLOC FOR LATER FIXUP.
TLO E,FPARBT ;MIGHT AS WELL USE THIS BIT...
MOVSI A,(<MOVEM>) ;NOW THE SECOND INSTR....
PUSHJ P,@EMITB(H)
PUSHJ P,SWAPON ;TURN OFF NOSWAP BIT
JRST GFUN11
GFUN12: TLNE E,ARRYBT ;BETTER BE AN ARRAY...
JRST GFUN11 ;IT IS.
PUSHJ P,DRYROT ;OOPS!
GFUNC4: MOVE T3,ACTB1(H) ;Pick appropriate set of AC's to save
MOVSI A,-NFACS ;PREPARE TO SEARCH AC'S 0-4.
SKIPN T,@T3 ;IS THIS ONE IN USE ?
AOBJN A,.-1 ;NO.
JUMPG A,GFUNC6 ;DID WE FIND A BUSY ONE ?
PUSHJ P,GSVAC ;YES. SAVE IT.
JRST GFUNC4
;NOW EMIT THE CALLING INSTR.
GFUNC6: POP OSP,A ;EMIT CALLING INSTRUCTION
LDB B,[POINT 4,A,17] ;RELOC. BITS.
TLZ A,37
PUSHJ P,@EMITB(H) ;
GFUN15: POP P,A ;GET PARAM. FROM STACK.
JUMPL A,CPOPJ ;IF IT'S THE MARK, RETURN.
TLZE A,FPARBT ;IS IT A FORMAL PARAMETER ?
JRST GFUN14 ; Yes, handle specially
TLNE A,SIACBT ;An I-time AC?
JUMPN H,[
WARN <Please MAIL LCS a message saying GFUN15 executed>
COMMENT ⊗ There was some question as if a compiler bug was fixed. ⊗;
PUSH OSP,A ;Put AC back on stack and make GMURK1
PUSHJ P,GMURK1 ;save it
MOVE A,E ;Now, prepare to put saved copy into
JRST GFUNC2 ] ;calling sequence
GFUNC2: LDB B,[POINT 4,A,17] ;RELOC. BITS.
TLZ A,37
TLZE A,ARRYBT ;IS IT AN ARRAY NAME ?
TLO A,INSXR ;YES. ADD INDEX FIELD.
GFUNC3: PUSHJ P,@EMITB(H) ;
PUSHJ P,SWAPON ;TURN OFF NOSWAP BIT
TLNE A,SIACBT ;I-Time AC?
SETZM IACS(A) ; Yes, forget we were using it (otherwise,
; it still points into PDL, which is then
; gets clobbered when GETAC is called. (This
; someday should be done in a better way)
TLNE A,SRACBT ;R-Time AC?
SETZM RACS(A) ; Yes, forget we were using it (see above)
JRST GFUN15 ;Do next argument
GFUN14: MOVEI B,.FXBTS ;YES. EMIT A FIXUP TO THE RIGHT INSTRUCTION.
TLZ A,400000+LRFXBT+SWAPBT ;A REPLACEMENT FIXUP TO RT. HALF.
TLO A,RRFXBT
PUSHJ P,@EMITB2(H) ;EMIT IT TO I-TIME OR R-TIME BUFER.
MOVEI B,0 ;NOW RESERVE SPACE FOR THE PARAM.
JRST GFUNC3
SUBTTL Unit Generator Call
; A UNIT GENERATOR CALL IS IN TWO PART, THE FIRST (WHICH IS OPTIONAL
; INITIALIZES THE UNIT GENERATOR AT I-TIME AND THE SECOND WHICH IS
; THE R-TIME CALL. THE SECOND PART LOOKS EXACTLY LIKE AN ORDINARY
; FUNCTION CALL AND THE FIRST PART GETS AS A ARGUMENT A POINTER TO
; THE END+1 OF THE R-TIME PART OF THE UNIT GENERATOR CALL. IT
; SHOULD KNOW WHERE TO GET THE ARGUMENTS IT NEEDS FROM THE R-TIME
; CALL
;
;;I-TIME code
; <I-time calling instruction>
; G0001
;
;;R-TIME code
; <R-time calling instruction>
; <arguments>
;G0001←←.+1
;IFE UGEXPF, < MOVEM RET,Un >
;
;
UGCALL: SKIPE IONLY
WARN(Attempt to call unit generator at I-Time)
COMMENT ⊗ Unit generators always run at least partially in R-Time.
What has probably happened was that this unit generator call somehow
managed to find its way inside an ≤I_ONLY≥ statement, which can easily
happen if you leave out an ≤END≥ from the construct ≤I_ONLY BEGIN...≥ ⊗;
PUSH P,CINST1 ;SAVE OLD COPY FOR RECURSION
DEBUG (UNIT GENERATOR CALL)
HRRZM A,CINST1# ;SAVE IT.
PUSHJ P,SCAN ;PEEK AT NEXT THING.
CAMN A,CTBL+"[" ;IS IT A [ ?
JRST GUG1 ;YES. UNIT GEN. HAS CONTROLLED CALLING RATE.
MOVEM A,SNCHR ;NO, IT'S PROBABLY THE (. PUT IT BACK WHERE
;SCAN WILL SEE IT AGAIN.
PUSHJ P,GUGCALL ;GENERATE TO UNIT GENERATOR CALL
POP P,CINST1 ;RESTORE OLD COPY
POPJ P, ;RETURN
;GENERATE UNIT GENERATOR CALL
GUGCALL: MOVE A,CINST1 ;RECOVER POINTER FOR USE OF FUNCAL.
PUSHJ P,FUNCA2 ;COMPILE CALL ON THE UNIT GEN.
PUSH P,A ;REMEMBER AC CONTAINING OUTPUT
SKIPE UGEXPF ;IS IT WITHIN AN EXPRESSION?
JRST GUGCA2 ;YES, DON'T MAKE AN U-SYMBOL FOR IT
MOVE B,VLOC ;NO, GET LOC. FOR OUTPUT OF UNIT GEN.
AOS C,UOPTR ;NO, INCREMENT COUNT OF UNIT GENS.
TLO B,RVBT ;IS THIS NEEDED??
MOVEM B,UOTBL(C) ;ENTER OUTPUT LOC. IN TABLE.
MOVE C,[MOVEM EMCDI] ;EMIT STORE INSTRUCTION TO
PUSHJ P,EMINST ;PUT OUTPUT OF UNIT GEN. AWAY.
PUSHJ P,EMDV ;MAKE ROOM IN VARIABLES AREA FOR IT.
GUGCA2: MOVE T,@CINST1 ;RETRIEVE PTR. TO RANDOM GOOD BITS.
SKIPN A,-1(T) ;DOES UNIT GEN. HAVE I-TIME CODE?
JRST GUGCA3 ;NO.
PUSHJ P,EMIABS ;YUP. EMIT THE CALLING INSTR.
HRRZ A,RLOC ;AS PARAMETER, GIVE IT A PTR. TO
SKIPE UGEXPF ;(IS THIS CALL WITHIN AN EXPRESSION?
ADDI A,1 ; YES, ACCOUNT FOR THE MISSING 'MOVEM')
MOVEI B,RRELBT ;JUST AFTER THE MOVEM EMITTED
PUSHJ P,EMICDI ;ABOVE.
GUGCA3: POP P,A ;GET BACK AC TO RETURN VALUE
POPJ P,
; IF THE NAME OF A UNIT GENERATOR IS FOLLOWED BY AN EXPRESSION
; IN SQUARE BRACKETS, THE U.G. GETS CALLED ONLY EVERY N TIME
; STEPS, WHERE N IS THE VALUE OF THE EXPRESSION.
; N IS RECALCULATED EVERY TIME THE U.G. IS CALLED.
;;I-TIME code
; SETZM TMP001
; <I-time calling instruction>
; G0001
;
;;R-TIME code
; AOSGE TMP001
; JRST G0001
; <expression>
; MOVEM AC,TMP001
; <R-time calling instruction>
; <arguments>
;IFE UGEXPF,< MOVEM RET,Un >
;IFN UGEXPF,< MOVEM RET,TMP002
;G0001:
;IFN UGEXPF,< MOVE RET,TMP002 >
;
GUG1: MOVE C,[AOSGE EMCDI] ;INSTR. TO COUNT NO. OF TIME STEPS TO SKIP THIS UG.
MOVE B,VLOC ;GRAB LOCATION IN VARIABLE AREA TO HOLD COUNT OF TIME STEPS TO SKIP.
MOVEI A,0 ;NO AC FIELD, PLEASE.
PUSHJ P,EMINST ;EMIT THE AOSGE JUST AHEAD OF THE CODE TO CALL THE U.G.
MOVE C,[SETZM EMICDI] ;ALSO EMIT AN INSTR. TO THE I-TIME
MOVE B,VLOC ;CODE TO INIT. THE COUNTER LOCATION TO 0 (SO U.G. GETS CALLED FIRST TIME).
PUSHJ P,EMINST
PUSH P,RLOC ;SAVE R-TIME LOC. COUNTER (FOR LATER FIXUP TO JRST WE ARE ABOUT TO EMIT).
PUSH P,VLOC ;ALSO VARIABLE LOC., FOR LATER LOADING OF THE STEPS-TO-SKIP COUNTER.
PUSHJ P,EMDV ;MAKE A WORD FOR IT.
MOVSI A,(<JRST>) ;NOW EMIT THE JUMP AROUND THE CALL OF
PUSHJ P,EMCDI ;THE U.G. !!"" N.B.: B IS 0 HERE FROM CALL ON EMDV !!
PUSHJ P,SEXPR ;NOW COMPILE THE EXPRESSION IN THE BRACKETS.
CAME A,CTBL+"]" ;SHOULD BE FOLLOWED BY ONE...
WARN <Missing ']' in unit generator call>
MOVEI H,1 ;INDICATE THAT WE ARE WORKING WITH R-TIME CODE...
PUSHJ P,GMURK1 ;..AND GET EXPR OFF OPERAND STACK.
PUSHJ P,GG2 ;NOW GET IT INTO AN AC.
MOVSI C,(<KIFIX>) ;EMIT INSTR. TO FIX VALUE OF EXPRESSION.
MOVE B,A ;Address is same as AC to get same effect.
PUSHJ P,EMINST
POP P,B ;GET LOCATION IN VARIABLE AREA OF THE STEPS-TO-SKIP COUNTER.
MOVSI C,(<MOVNM>) ;AND EMIT INSTR. TO STORE NEGATIVE OF COUNT THERE.
PUSHJ P,EMINST
PUSHJ P,GUGCALL ;NOW GENERATE CALL ON UNIT GENERATOR.
POP P,UGTMP# ;PUT LOC. OF THE JRST UNDER THE AOSGE SOMEWHERE SAFE
SKIPN UGEXPF ;IS IT WITHIN AN EXPRESSION?
JRST GUG1A ;NO
MOVE B,VLOC ;YES, SAVE SOME SPACE TO KEEP IT
PUSH P,A ;REMEMBER AC CONTAINING OUTPUT
PUSH P,B ;REMEMBER TMP. VAR. SOMEWHERE
MOVE C,[MOVEM EMCDI]
PUSHJ P,EMINST ;SAVE OUTPUT SOMEWHERE
PUSHJ P,EMDV ;THIS MUNGS 'B'
GUG1A: MOVE A,UGTMP ;GET ADDRESS OF JRST UNDER THE AOSGE
MOVEI B,.FXBTS ;EMIT FIXUP TO MAKE IT POINT HERE (I.E. AFTER
PUSHJ P,EMCD ; END OF U.G. CALL)
SKIPN UGEXPF ;WITHIN AN EXPRESSION?
JRST GUG1B ;NO
MOVE C,[MOVE EMCDI]
POP P,B ;EMIT CODE TO PICK UP OUTPUT
POP P,A
PUSHJ P,EMINST
GUG1B: POP P,CINST1 ;RESTORE OLD COPY OF CINST1 AND
POPJ P, ;RETURN
SUBTTL Enter Item into Symbol Table
;; UTILITY ROUTINE TO ENTER AN ITEM IN THE MAIN SYMBOL TAB.
GETNAM: PUSHJ P,SCANV ;SCAN AN IDENTIFIER.
GETNM1: AOS T,(P) ;TO SKIP PARAM ON RETURN.
JUMPE A,GNM2 ;SHOULD BE UNDEFINED...
TLOE A,DF ;IT'S NOT. MAYBE IT'S A DELIMITER ?
ERROR (Missing IDENTIFIER)
SKIPE BLEVEL ;IS IT WITHIN A BEGIN-END
JRST GNM2 ;YES, THEN DON'T MESS AROUND!
; TLNN A,@-1(T) ;NO. MAYBE ALREADY RIGHT TYPE ? *** BAGBITING DWP CODE
HLRZ B,(A) ;GET ORGINAL GOODBITS INTO RH
CAIE B,@-1(T) ;THIS COMPARES WITH ADDRESS (INSTEAD OF
; CONTENTS, AS CAME B,-1(T))
SKWARN (Multiply defined symboi)
JRST GNM2 ;ENTER NEW COPY OF SYMBOL
SKIPGE -1(T) ;AH, IT IS. SHOULD WE REENTER IT ?
POPJ P, ;NO. ITS OLD ENTRY WILL DO.
GNM2: HRLZ A,-1(T) ;YES. GET TYPE BITS.
AENTER: LDB T,[POINT 6,ACCUM,5] ;GET CHARACTER COUNT
IDIVI T,6 ;NUMBER OF WORDS - 1
ADDI T,3 ;PLUS 1+GOODBITS WORD+LINK
PUSHJ P,GPS ;GET A BLOCK TO HOLD IT
MOVE T
; HRRZ JOBFF ;GET NEXT FREE LOCATION. *****
HRRZ B,CBNO ;GET BUCKET NO. OF THING JUST SCANNED.
EXCH BUCTBL(B) ;UPDATE BUCKET HEAD.
; AOS B,JOBFF ;*****
AOS B,T
MOVEM -1(B) ;PUT THE LINK IN THE NEW ENTRY.
MOVEM A,1(B) ;PUT THE RANDOM GOOD BITS IN.
MOVE ACCUM ;GET FIRST WORD OF NAME.
MOVEM (B) ;PUT IN TABLE.
AOS B,T
; AOS B,JOBFF ;*****
MOVEI T2,ACCUM+1;PREPARE TO MOVE REST OF NAME.
AEL1: AOS T
; AOS JOBFF ;*****
SKIPN T1,(T2) ;ANY MORE OF THE NAME ?
JRST AEL2 ;NO.
MOVEM T1,(T) ;YES. PUT IN TABLE. *****
CAIL T2,ACCUM+2 ;UNLESS FIRST OR SECOND WORD,
SETZM (T2) ;ZERO WORD IN ACCUM.
AOJA T2,AEL1
AEL2:
HRR A,B
; HRRZ JOBFF ;*****
; HRLM JOBSA ;*****
POPJ P,
SUBTTL Declarations
;Variable declaration
EXTERNAL JOBDDT,JOBREL
;<VARIABLE DECLARATION> ::= VARIABLE <VAR. DEC. LIST>
;<VAR. DEC. LIST> ::= <VAR. DEC.>|<VAR. DEC. LIST>|<DEC. DEC.>
;<VAR. DEC.> ::= <IDENTIFIER>|/<IDENTIFIER>
DVRBL1: CAME A,COMMAV ;IS IT A COMMA ?
POPJ P, ;NO. END OF DECL.
DVRBL: PUSHJ P,SCAN ;GET NEXT ITEM.
CAMN A,CTBL+"/" ;IS IT A "/" ?
JRST DVRBL2 ;YES. DEFINE FOLLOWING VARIABLE AS R-TIME.
PUSHJ P,GETNM1 ;NO. MUST BE NAME OF VARIABLE. PUT IN SYM. TABLE.
XWD 400000,VRBLBT ;PARAM. TO GETNM1.
DVRBL4: JUMPL A,DVRBL3 ;WAS IT ALREADY DEFINED ?
MOVEI T,1
PUSHJ P,GPS ;GET A WORD
; AOS A,JOBFF ;NO, IT'S NEW. LEAVE WORD FOR THE VALUE. *****
; SUBI A,1 ;GET PTR. TO THAT WORD.
HRRM T,(B) ;PUT IN GOOD BITS WORD (NO REL. BITS).
DVRBL3: PUSHJ P,SCAN ;GET COMMA OR SEMICOLON.
JRST DVRBL1 ;BACK FOR MORE.
DVRBL2: PUSHJ P,GETNAM ;SCAN AND ENTER NAME OF VARIABLE.
XWD 400000,VRBLBT!RVBT ;INCLUDE 'R-TIME' BIT.
JRST DVRBL4
.UG: ERROR<Unit Generators must be external>
COMMENT ⊗ Should be preceded with the symbol EXTERNAL. External unit generators
are written with FAIL or MACRO and loaded with the Music Compiler. ⊗;
UGDEF: PUSHJ P,GETNAM ;Get & set name of Unit Generator
XWD 400000,UGBIT
PUSH P,B
PUSHJ P,[PUSHJ P,SYMSCH ;FIND STARTING ADDRESS.
ERROR (Missing External function)
COMMENT ⊗ Either an external function was not loaded or its name was misspelled.⊗;
POPJ P,]
POP P,B
MOVEI A,@-2(A) ;Parameters are located on back from unit generator itself
HRRM A,(B) ;Set address of unit generator
PUSHJ P,SCAN
CAMN A,COMMAV ;Another item?
JRST UGDEF ; Yes, define it, too
POPJ P, ;No, return
NXFUN: 0
ERROR (Missing External function)
COMMENT ⊗ Either an external function was not loaded or its name was misspelled.⊗;
JRST NXFUN+1
; Function declaration
DF5: CAME A,COMMAV ;ARE THERE MORE DEFINITIONS ?
POPJ P, ;NO.
DFUNC: TRO FL,CSBRBT+SFOOBT ;ENTER FUNCTION DEFINING MODE.
DEBUG (FUNCTION DEFINTION)
PUSHJ P,GETNAM ;GET FUNCTION NAME.
EXP FUNBIT ;PARAMETER TO GETNAM.
PUSH P,A ;SAVE NAME
; PUSH P,BUCTBL ;####$$%%$ A TEMPORARY KLUGE !!
JSR PUSHBUCKBL ;SAVE SYMBOL TABLE POINTERS
PUSH P,RETFIX ;SAVE FIXUP WORD
SETZM RETFIX
MOVEI T,5
PUSHJ P,GPS ;GET A 5 WORD BLOCK
MOVE A,T ;(FOR COMPATABLITY)
; MOVE A,JOBFF ;GET FIRST FREE STORAGE LOC. *****
HRRM A,(B) ;MAKE GOOD BITS WORD POINT THERE.
HRLI A,600 ;MAKE A INTO A BYTE POINTER.
PUSH P,A
PUSH P,A
IBP (P) ;THIS POINTER IS FOR PARAMETER DESCRIPTORS.
HRLI A,400000+LRFXBT+RRFXBT ;NOW EMIT FIXUP TO THE
;LOCATION IN THE SYM. TABLE WHICH WILL
MOVEI B,.FXBTS ;CONTAIN THE CALLING INSTR. FOR THE
;FUNCTION, SO IT CAN BE UPDATED AT
PUSHJ P,EMICD ;LOAD TIME WITH THE RELOCATED ADDRESS OF THE FUNCTION.
; ADDI A,5 ;LEAVE ENOUGH ROOM FOR 22 PARAMETER
; HRRZM A,JOBFF ;DESCRIPTORS. *****
TRNN FL,EXTFLG ;IS IT AN EXTERNAL FUNCTION ?
SKIPA A,ILOC ;NO. ADDRESS IS IN ILOC.
PUSHJ P,[PUSHJ P,SYMSCH ;YES. FIND STARTING ADDRESS.
ERROR (Missing External function)
COMMENT ⊗ Either an external function was not loaded or its name was misspelled.⊗;
POPJ P,]
TLO A,(<JSA RA,>) ;MAKE INTO A CALLING INSTR.
MOVEM A,@-1(P) ;PLACE IN SYM. TABLE.
LDB B,[POINT 4,A,17] ;GET THE RELOCATION BITS.
TLZ A,17 ;TURN THEM OFF IN THE INSTRUCTION WORD.
PUSHJ P,EMICD ;EMIT AS VALUE OF ABOVE FIXUP.
PUSH P,[-1] ;INIT. THE PARAMETER COUNT.
PUSHJ P,SCAN ;LOOK AT NEXT THING.
CAME A,LPARV ;A ( ?
JRST DFNOPR ;NO. THERE ARE NO PARAMETERS.
DF2: PUSHJ P,SCAN ;SCAN A PARAMETER.
CAMN A,STRV ;IS IT A STRING PARAMETER?
JRST [ PUSHJ P,DFGSYM ;YES, GET AN IDENTIFIER
HRLI A,FPARBT!STRFLG ;SET STRING BITS
PUSHJ P,AENTER ;ENTER SYMBOL INTO TABLE
MOVEI STRPAR ;THE TYPE OF PARAMETER
JRST DF2B] ;PUT IN INTO FUNCTION DESCRIPTOR
CAMN A,ARRV ;IS IT A ARRAY PARAMETER?
JRST [ PUSHJ P,DFGSYM ;YES, GET AN IDENTIFIER
HRLI A,FPARBT!ARRYBT ;SET ARRAY BITS
PUSHJ P,AENTER ;ENTER SYMBOL INTO TABLE
MOVEI ARRPAR ;THE TYPE OF PARAMETER
JRST DF2B] ;PUT IN INTO FUNCTION DESCRIPTOR
CAMN A,INTGV ;IS IT A INTEGER PARAMETER?
JRST [ TRNN FL,EXTFLG ;YES, IS IT AN EXTERNAL FUNCTION?
ERROR <INTEGERS PRESENTLY ALLOWED ONLY FOR EXTERNAL FUNCTIONS, SORRY>
PUSHJ P,DFGSYM ;MAKE SURE IT'S A GOOD IDENTIFIER
HRLI A,FPARBT!VRBLBT!FIXFLG ;SET BITS FOR INTEGER
PUSHJ P,AENTER ;ENTER SYMBOL INTO TABLE
MOVEI INTPAR ;THE TYPE OF PARAMETER
JRST DF2B] ;PUT IN INTO FUNCTION DESCRIPTOR
; More Function Declaration
DF2A: PUSHJ P,DFGSY2 ;MAKE SURE IT'S A VALID IDENTIFIER
HRLI A,FPARBT!VRBLBT ;MAKE A INTO FORMAL PARAM. INDICATOR
; TRNE FL,ARRFLG
; HRLI A,FPARBT!ARRYBT ;IF IT'S AN ARRAY
PUSHJ P,AENTER ; AND ENTER THE SYMBOL.
MOVEI VARPAR ;PUT 'ORDINARY' FLAG IN THE PARAMETER
; TRZE FL,ARRFLG ;AN ARRAY NAME PARAM. ?
; MOVEI ARRPAR ;YES. USE RIGHT DESCRIPTOR BIT.
DF2B: IDPB -1(P) ;DESCRIPTOR FOR THIS PARAM.
PUSHJ P,SCAN
CAMN A,COMMAV ;A COMMA ?
JRST DF2 ;YES LOOK FOR MORE PARAMETERS.
CAME A,RPARV ;IT BETTER BE A ).
ERROR <Missing ')' in function definition>
PUSHJ P,SCAN ;GET THE =.
MOVEI B,0 ;FLAG END OF PARAMETER DESCRIPTORS.
IDPB B,-1(P)
DFNOPR: TRNE FL,EXTFLG ;IS THIS AN EXTERNAL FUNCTION ?
JRST DF4 ;YES. LOOK FOR NO DEFINITION.
PUSH P,IONLY ;SAVE STATE OF IONLY FLAG
SETOM IONLY
CAMN A,SEMICV ;IS IT THE LONG FORM?
JRST DFLONG ;YES, BETTER BE A BLOCK
CAMN A,CTBL+"=" ;NO, MUST BE A '=` OR '←`
JRST .+3
CAME A,LARV
ERROR <Missing ';' or '=' in function definition>
PUSHJ P,EMICDI ;LEAVE ROOM FOR THE JSA WORD.
TRZ FL,SFOOBT ;LET SCANNER SEE FOO-SYMBOLS AGAIN.
PUSHJ P,SEXPR ;SCAN AN EXPRESSION.
POP P,IONLY ;RESTORE I-ONLY FLAG
JRST DF4
DFLONG: PUSHJ P,EMICDI ;LEAVE ROOM FOR THE JSA WORD.
TRZ FL,SFOOBT ;LET SCANNER SEE FOO-SYMBOLS AGAIN.
PUSHJ P,SCAN ;BETTER BE A 'BEGIN'
CAME A,BEGINV
ERROR <Missing 'BEGIN' in function definition>
PUSHJ P,CBLOCK ;COMPILE A BLOCK
PUSH P,A
SKIPN A,RETFIX ;ANY RETURN STATEMENTS?
JRST DF4B ;NO
TLO A,CHAINBT ;A CHAIN FIXUP
MOVEI B,.FXBTS
PUSHJ P,EMICD
DF4B: POP P,IONLY ;RESTORE I-ONLY FLAG
JRST DF4A
DF4: PUSH P,A
TRNE FL,EXTFLG ;AN EXTERNAL ?
DF4A: SKIPA E,[XWD SIACBT,0] ;YES. RESULT ALWAYS IN 0.
PUSHJ P,GMURK1 ;GET IT OFF STACK.
PUSHJ P,GG2 ;MAKE SURE ITS IN AN AC.
IDPB A,-2(P) ;TELL UNIVERSE WHICH AC .
AOS B,-1(P) ;ADJUST PARAMETER COUNT.
IDPB B,-3(P) ;PUT IN SYM. TABLE.
MOVEI A,RA ;EMIT RETURN INSTR.
MOVSI C,(<JRA RA,(RA)>)
TRNN FL,EXTFLG ;...UNLESS THIS IS AN EXTERNAL.
PUSHJ P,EMINST
AOS A,-2(P) ;FIND TOP OF PARAM. DESC. STRING.
; HRRZM A,JOBFF ;RESET FREE STORAGE. *****
; HRLM A,JOBSA ;*****
POP P,A
SUB P,[XWD 3,3] ;FORGET JUNK IN STACK.
; POP P,BUCTBL ;##$$%$# MORE OF THAT KLUGE !!!
POP P,RETFIX ;RESTORE FIXUP WORD
JSR POPBUCTBL ;RESTORE SYMBOL TABLE POINTERS
EXCH A,(P) ;SAVE SCANNED SYMBOL AND GET NAME
PUSHJ P,DCLMSG ;PRINT MESSAGE
JUMP [ASCIZ/FUNCTION - /]
POP P,A ;RESTORE SCANNED SYMBOL
TRZ FL,CSBRBT+SFOOBT ;LEAVE FUNCTION DEFINING MODE.
JRST DF5 ;ALL DONE.
DFGSYM: PUSHJ P,SCAN
DFGSY2: TLNE A,DF+NUMFLG ;GET A SYMBOL AND CHECK FOR VALID IDENTIFY
WARN <ILLEGAL FORMAL PARAMETER>
AOS A,-1(P) ;INCREMENT PARAMETER COUNT.
POPJ P,
; Instrument Declaration
;; MORE SYNTAX ANALYZER. COMPILE AN INSTRUMENT DEFINITION.
CINS: TRON FL,INSDEF ;ARE WE INSIDE AN INSTRUMENT DEFINITION
SKIPE BLEVEL ;OR BLOCK
ERROR (Missing 'END')
PUSHJ P,GETNAM ;GET NAME OF INSTRUMENT.
EXP INSBIT ;PARAMETER TO GETNAM.
PUSH P,A ;SAVE NAME
MOVEI T,1 ;GET A WORD
PUSHJ P,GPS
MOVE A,T ;(FOR COMPATABILITY)
; AOS A,JOBFF ;GET PLACE FOR MORE GOOD BITS.. *****
; SUBI A,1
HRRM A,(B) ;MAKE RANDOM BITS WORD POINT THERE.
HRLI A,RRFXBT ;RIGHT HALF REPLACEMENT TYPE FIXUP.
MOVEI B,.FXBTS ;EMIT FIXUP TO RIGHT HALF FROM
PUSHJ P,EMICD ;FIRST LOC. OF I-TIME CODE.
HRLI A,LRFXBT+SWAPBT ;FIXUP TO LEFT HALF FROM FIRST LOC.
PUSHJ P,EMCD ;OF R-TIME CODE.
;CINS5: PUSHJ P,SCAN
;CINS3: PUSHJ P,SMCS1 ;IGNORE SEMICOLON, IF ANY.
; CAMN A,ENDV ;IS IT AN END ?
; JRST CINSE ;YES.
; TLNE A,UGBIT ;IS IT A UNIT GENERATOR CALL ?
; JRST [ PUSHJ P,UGCALL
; JRST CINS5] ;BACK FOR MORE.
;CINS4: PUSHJ P,STAT ;ITS NOT A UNIT GEN. CALL.
; JRST CINS3 ;NO
PUSHJ P,CBLOCK
EXCH A,(P) ;SAVE SCANNED SYMBOL AND GET BACK NAME
PUSH P,A ;SAVE IT TOO
CINSE: SETZM IARR1 ;YES. ZERO THINGS.
MOVE [XWD IARR1,IARR1+1]
BLT IARR2-1
SETOM IARR1 ;SET THESE TO -1
MOVE [XWD IARR2,IARR2+1]
BLT IARR5-1
SETZM IARR4 ;YES. ZERO THINGS.
MOVE [XWD IARR4,IARR4+1]
BLT IARR3-1
MOVE A,[POPJ P,] ;PUT RETURN INSTR. AT END OF
MOVEI B,0 ;THE I-TIME CODE.
PUSHJ P,EMICDI
PUSHJ P,EMCDI ;ALSO THE R-TIME CODE.
CINSR1: POP P,A ;RECOVER NAME
PUSHJ P,DCLMSG ;PRINT MESSAGE
JUMP [ASCIZ/INSTRUMENT - /]
; PUSHJ P,SCAN
POP P,A ;RESTORE SCANNED SYMBOL
TRZ FL,INSDEF ;CHANGE THIS LATER ****
POPJ P,
; Array Definition
;NO MORE SHALL THIS CODE GET ILL MEM REFS!!!!
COMMENT ⊗ Symbol table format for array
<link to next symbol>
<length, first 5 characters>
<goodbits>,,<array address>
<symbol table entry>
FOO.(INSXR)
<length>
FOO.: BLOCK <length>
⊗;
DARR: PUSH P,[0] ;DEFINE SOME ARRAYS.
DARR1: PUSHJ P,GETNAM ;SCAN NAME.
XWD DF,ARRYBT ;TYPE PARAMETER TO GETNAM.
DEBUG (ARRAY DEF)
PUSH P,A ;STACK PTR. TO ENTRY.
PUSHJ P,SCAN ;LOOK FOR COMMA OR '(' OR '['
CAME A,LPARV ;Can be a (.
CAMN A,LFTBRK ;or a [
JRST DARR1A
CAMN A,COMMAV ;Else must be a ','.
JRST DARR1 ;YES. GET MORE NAMES.
ERROR <Missing '(' in array declaration>
DARR1A: PUSHJ P,SCAN ;GET THE DIMENSION.
TLNN A,NUMFLG ;MAKE SURE IT'S A NUMBER.
ERROR <Dimension should be a number>
COMMENT ⊗ Dynamic arrays are not implimented. ⊗;
MOVE B,(A) ;GET VALUE.
TLNN A,FIXFLG ;IS IT FLOATING ?
KIFIX B,B
DARR3: POP P,T ;PTR. TO NAME IN TABLE...
JUMPE T,DARR2 ;UNLESS ITS THE MARK.
JUMPG T,DARR4 ;WAS IT PREVIOUSLY DEFINED ?
HRRZ T1,(T) ;YES. GET ITS BASE ADDRESS.
JUMPE T1,DARR4 ;IN CASE WE GOT INTERRUPTED
CAMG B,-1(T1) ;IS NEW DIMENSION > OLD ?
JRST DARR3 ;NO. LEAVE OLD DEFINITION ALONE.
DARR4: PUSH P,T ;SAVE NAME
MOVEI T,3(B) ;DIMENSION+2
PUSHJ P,GPS ;GET SOME CORE
MOVEI A,3(T) ;(FOR COMPATABLITY)
POP P,T ;RECOVER NAME
HRRM A,(T) ;PUT IN SYM. TABLE.
MOVEM B,-1(A) ;PUT DIMENSION IN -1TH ELEMENT.
HRLI A,INSXR ;PUT GOOD INDEX FIELD IN A...
MOVEM A,-2(A) ;PUT PTR. TO ARRAY WITH INDEX IN AR[-2]
MOVEM T,-3(A) ;PUT PTR. TO SYM. TABLE ENTRY FOR DEBUGGING IN AR[-3]
MOVE A,T ;FOR PRNTSYM
PUSHJ P,DCLMSG ;PRINT MESSAGE
JUMP [ASCIZ/ARRAY - /]
JRST DARR3 ;TRY FOR ANOTHER.
DARR2: PUSHJ P,SCAN ;GET THE ).
CAMN A,COMMAV ;IS IT AN COMMA?
ERROR <Multiply dimensional array not implimented, sorry>
CAMN A,RPARV ;Can be ')'
JRST DARR2A
CAME A,RGTBRK ;Or ']'
WARN <Missing ')' in array declaration>
DARR2A: PUSHJ P,SCAN
CAMN A,COMMAV ;A COMMA ?
JRST DARR ;YES. START OVER AGAIN.
POPJ P,
SUBTTL The Loader
;; THE WONDERFUL, WINNING LOADER.
BEGIN LOADER
R←1
I←2
V←3
VW←A
XY←B
LOC←C
TYPE←H
COMMENT ⊗ RELOCATION BYTE FORMAT
_______________
| | | | |
| V | W | X | Y |
|___|___|___|___|
VW=0 XY=0 UNRELOCATED DATA
XY≠0 ENDMARK IF DATA=0 ELSE FIXUP
VW≠0 XY=0 RESET LOC. COUNTER (NOT IMPLEMENTED, ERROR CONDITION)
VW=01 R-TIME RELOCATION
VW=10 I-TIME RELOCATION
VW=11 VARIABLE AREA RELOCATION
X=0 RELOCATE LEFT HALF
Y=0 RELOCATE RIGHT HALF
⊗;
↑LOADER:
HRRZ T,RLOC ;SEE HOW MUCH CORE WE NEED
ADD T,ILOC
ADD T,VLOC
HRRZ T,T ;(Note: could be requesting zero words. Probably
; should do something about that like return
; quickly)
PUSHJ P,GPS ;GET IT
MOVEM T,LSTLOA ;FOR DEBUGGING!
COMMENT ⊗ WOW, HOW DID THIS HAPPEN, I-TIME CODE MUST BE LOADED BEFORE
;R-TIME CODE!!!
MOVE R,T
; MOVE R,JOBFF ;R-TIME CODE RELOCATION CONST. *****
HRRZ I,RLOC
ADD I,R ;I-TIME CONST.
HRRZ V,ILOC
ADD V,I ;VARIABLE RELOC. CONST.
⊗;
MOVE I,T
HRRZ R,ILOC
ADD R,I ;I-TIME CONST.
HRRZ V,RLOC
ADD V,R ;VARIABLE RELOC. CONST.
MOVE T3,V
ADD T3,VLOC ;PROGRAM BREAK.
HRRZ A,T3
HRL A,I ;WE START WITH I-TIME CODE NOW!
HRRI A,1(I)
SETZM (I)
BLT A,-1(T3)
MOVEI TYPE,0 ;START WITH R-TIME CODE.
NXTCHN:
ADDI TYPE,1 ;GO TO NEXT CHAIN OF BUFFERS.
CAILE TYPE,3 ;ALL DONE ?
; POPJ P, ;YES.
JRST [ DEBUG2(LOADED) ;A HANDY BREAKPNT FOR MODE 4
POP OSP,BEGFRE ;RELEASE FREE STORAGE USED IN
MOVE 1,LSTLOA ;RETURN ADDRESS IN 1
POPJ P,] ;COMPILATION (SEE ENDP1)
PUSH P,[NEXT1] ;FAKE UP A RETURN TO LDL1.
MOVE LOC,(TYPE) ;INIT. THE CURRENT LOC. COUNTER.
SKIPA F,FCBUF-1(TYPE) ;PTR. TO FIRST BUF. OF CHAIN.
NXTBUF:
HRRZ F,(F) ;PTR. TO NEXT BUF. OF CHAIN.
HRRZ E,F ;SET UP BYTE PTR. TO RELOC. BITS.
HRLI E,200
HRRZI D,LOBUFS/12+2(F) ;PTR. TO DATA IN BUF.
HRLI D,-<LOBUFS-LOBUFS/12-2> ;WORD COUNT.
GETWRD: AOBJP D,NXTBUF ;WORD COUNT EXHAUSTED ?
MOVE (D) ;NO. PICK UP NEXT DATA WORD.
ILDB VW,E ;FIRST 2 REL. BITS.
ILDB XY,E ;LAST 2.
POPJ P,
NEXT: PUSHJ P,GETWRD ;GET NEXT WORD FROM BUFFER.
NEXT1: JUMPE VW,FIXUP ;VW=0, NO REL. GIVEN; MAY BE A FIXUP.
JUMPE XY,RESETP ;XY=0, IF NEITHER HALF, THEN IT'S A RESET.
PUSH P,CPUTWRD ;ANOTHER FAKE RETURN ADDRESS.
RELOCATE: TRNE XY,1 ;RELOCATE RIGHT HALF ?
ADD (VW) ;YES.
TRNN XY,2 ;LEFT HALF ?
POPJ P, ;NO.
MOVSS (VW)
ADD (VW)
MOVSS (VW)
POPJ P,
PUTWRD: ADDM (LOC) ;PUT IN CORE.
CNEXT: AOJA LOC,NEXT ;GET ANOTHER.
; More Loader (But not much more, you will notice!).
COMMENT ⊗ FIXUPS
VW=0; XY≠0; DATA≠0
FIXUP DATA WORD:
_ ___ _ _____________ _ _ ___ _________________________________
| | | | | | | | | | |
|B|L|R|S|C| |V|W| | POINTER TO ADDRESS TO FIXUP |
|_|_|_|_|_|___________|_|_|___|_________________________________|
0 1 2 3 4 14 15 18
VW RELOCATE THE ADDRESS AS IN DATA WORDS
B=0 (NXTWRD) LOC. COUNTER IS THE FIXUP DATA
B=1 THE FOLLOWING WORD IN THE BUFFER
L=1 (RLFXBT) RELOCATE LEFT HALF
R=1 (RRFXBT) RELOCATE RIGHT HALF
S=1 (SWAPBT) THE HALF-WORDS ARE EXCHANGED.
C=1 (CHAINBT) CHAIN FIXUP (IF ADDRESS PART OF WORD POINTED TO
IS NON-ZERO, THEN PREFORM CHAIN FIXUP OF THAT ONE
TOO, REPEATING UNTIL ADDRESS PART IS ZERO)
⊗;
FIXUP:
CPUTWRD:JUMPE XY,PUTWRD ;XY=0, PERHAPS NOT A FIXUP.
JUMPE NXTCHN ;VW=0, XY≠0, IT MIGHT EVEN BE AN END MARK.
LDB T3,[POINT 2,0,15] ;A FIXUP. GET REL. BITS FOR PTR.
DPB T3,[POINT 5,0,17]
PUSH P,0
JUMPG USEPC ;IS VALUE OF FIXUP TO BE FOUND IN BUFFER ?
PUSHJ P,GETWRD ;YES. GET IT.
PUSHJ P,RELOCATE ;PERFORM ANY INDICATED RELOCATION ON IT.
SKIPA T3,0 ;MOVE RELOCATED VALUE INTO T3.
USEPC: MOVE T3,LOC ;VALUE IS CURRENT LOCATION.
POP P,0 ;BRING BACK THE POINTER WORD.
TLNE CHAINBT ;IS THIS A CHAIN FIXUP?
JRST FXCHAIN ;YES
TLNE SWAPBT ;SHOULD WE EXCHANGE HALVES OF THE VALUE ?
MOVSS T3 ;YES.
TLNE RRFXBT ;SHOULD WE REPLACE THE RIGHT HALF OF THE LOCATION ?
HRRM T3,@0 ;YES. SEE THE POINTER RELOCATION HAPPEN AUTOMATICALLY !!
TLNE LRFXBT ;REPLACE THE LEFT HALF ?
HLLM T3,@0 ;YES.
TLNN LRFXBT+RRFXBT ;IF NEITHER HALF REPLACED, THEN
ADDM T3,@0 ;IT'S AN ADDITIVE FIXUP.
JRST NEXT ;BACK TO MAIN LOOP.
FXCHA2: HRRZ 0,XY ;GET ADDRESS FOR NEXT FIXUP
JUMPE NEXT ;BACK TO MAIN LOOP
FXCHAIN: HRRZ XY,@0 ;SAVE NEXT PART OF CHAIN
HRRM T3,@0 ;DO FIXUP
JRST FXCHA2 ;DO NEXT OF CHAIN
RESETP: LDB T3,[POINT 2,0,19]
CAMN T3,TYPE ;BETTER AGREE WITH CURRENT RELOCATION
TLNN 1 ;AND IT BETTER LOOK LIKE IT TOO
PUSHJ P,DRYROT ;IS NOT! SOMETHING IS VERY WRONG!!!!
PUSHJ P,RELOCATE
MOVE LOC,0 ;SET IT
JRST NEXT
BEND LOADER
DRYROT:
ERROR (C O M P I L E R E R R O R ! ! !
Get TOVAR or save this core image and A COPY OF THE INPUT FILE and leave a
message by saying MAIL TVR!!!)
COMMENT ⊗ Something unexpected has happened which would probably should be
looked at as it is most likely a bug. ⊗;
SUBTTL Outer Loop
; HERE IS THE OUTER LOOP OF THE WHOLE SYSTEM.
CHOWN1: PUSHJ P,INTER1 ;INTERPRET STATEMENT.
SCHOWN: PUSHJ P,SMSC1 ;GET FIRST NON-SEMICOLON.
MOVE JOBREL
MOVEM BEGFREE ;*****
SUB JOBFF
SKIPN GETMORE# ;DO WE NEED TO GET MORE?
CAIGE =1024 ;NO, DO WE HAVE AT LEAST 2K WORDS OF CORE?
COREFULL ;COREFULL WILL KINDLY GET US SOME MORE
SETZM GETMORE ;CLEAR CORE REQUEST FLAG
CHOWN: CAMN A,PLAYV ;IS IT A 'PLAY' SECTION ?
JRST PLAY1 ;YES.
CAMN A,ALTV ;IS IT AN ALT MODE ?
JRST COMMND ;YES. A COMMAND FOLLOWS.
CAMN A,EXTV ;AN EXTERNAL DECLARATION
JRST CHOWN2 ;YES, BETTER BE READY TO GENERATE CODE
CAME A,INSV ;IS IT A INSTRUMENT DEFINITIN?
CAMN A,FUNV ;A FUNCTION DEFINITION?
JRST [CHOWN2: PUSHJ P,SCOMP ;INIT. COMPILER
SETZ H,
PUSHJ P,(A) ;DO DEFINITION
PUSHJ P,ENDP1 ;CLEAN UP COMPILER
PUSHJ P,LOADER ;LOAD DEFINITION
JRST SCHOWN]
TLNE A,DF ;IS IT A DECLARATION?
TLNN A,DECLBIT
JRST CHOWN1 ;NO. JUST A STATEMENT.
PUSHJ P,(A) ;DO DECLARATION
CAMN A,SEMICV ;BETTER BE A SEMICOLON
JRST SCHOWN ;GO BACK FOR MORE
WARN(Missing ';')
JRST CHOWN
;A COMPILE BLOCK
COMPL1: PUSHJ P,SCOMP ;INIT. THE COMPILER.
PUSHJ P,SCAN
COMPL2: PUSHJ P,SMCS1 ;SCAN TO NEXT SEMICOLON
CAME A,FINV ;A FINISH?
CAMN A,FINIV ;OR A 'FINI'?
JRST COMPDN
TLNE A,DF ;A DECLARATION?
TLNN A,DECLBIT
JRST [WARN <A simple statement inside a 'COMPILE' section just wastes space!>
COMMENT ⊗ It will never be executed. ⊗;
PUSHJ P,STAT ;EAT IT ANYWAY...
JRST COMPL3]
PUSHJ P,(A) ;YES, DO IT
COMPL3: CAME A,SEMICV ;BETTER BE A SEMICOLON
WARN <Missing ';'> ;OH, WELL...
JRST COMPL2
COMPDN: PUSHJ P,ENDP1 ;DONE WITH COMPILATION
PUSHJ P,LOADER ;LOAD THE CODE.
JRST SCHOWN ;DONE WITH THAT SECTION.
PLAY1: SETZ A,
RUNTIM A,
MOVEM A,RUNTIM# ;SAVE FOR STATISTICS LATER
TIMER A,
MOVEM A,BEGTIM#
PUSHJ P,PLINIT ;WE'RE GOING TO PLAY; GET SAMPLE BUFFER.
AOS SBCNT
LDB A,[POINT 6,SBPTR,11];Calculate maximum possible sample
SETO 0, ;from byte size for output
LSH 0,-1(A)
SETCAM 0,OVRSMP# ;Remember it somewhere
PLAY1A: SETZM TIME# ;T←0.
SETZM RQPTR# ;RUN QUEUE IS EMPTY.
SKIPN BLKNUM ;DON'T RESET MAXSMP IF APPENDING
SETZM MAXSMP# ;INIT. THE MAXIMUM SAMPLE REMEMBERER.
PLAY2: PUSHJ P,SMSC1 ;SCAN A NON-SEMICOLON.
CAMN A,FINIV ; A 'FINI'?
JRST PTERM
CAME A,FINV ;A 'FINISH ' ?
CAMN A,PLAYV ;... OR A 'PLAY' ?
JRST PTERM ;YES. END OF SECTION.
TLNE A,INSBIT ;AN INSTRUMENT NAME ?
JRST PINS ;YES. A NOTE STATEMENT.
PUSH P,[PLAY2] ;NO. INTERPRET THE STATEMENT.
INTER1: CAME A,INSV
CAMN A,FUNV
ERROR <NOT ALLOWED IN 'PLAY' SECTION>
PUSHJ P,SCOMPA ;IT MUST BE A RANDOM STATEMENT.
;PREPARE TO INTERPRET IT BY
;INITIALIZING THE COMPILER.
SETOM IONLY ;DON'T GENERATE R-TIME CODE AS ATTEMPTS TO DO
;SO CONFUSE THE COMPILER (SEE GM3)
PUSHJ P,STAT ;COMPILE THE STATEMENT.
;INTERPET THE CODE JUST COMPILED
INTERP: MOVE A,[JRST INTER2] ;PREPARE TO EXECUTE TEMPORARY
MOVEI B,0 ;CODE (I.E., RUN IN INTERPRET MODE).
; PUSHJ P,EMICDI ;EMIT RETURN INSTR. AT END OF CODE.
PUSHJ P,@EMITB(H);EMIT RETURN INSTR. AT END OF CODE.
PUSHJ P,ENDP1 ;CLEAN UP COMPILER.
PUSH P,JOBFF ;SAVE FREE STG. PTR. *****
PUSHJ P,LOADER ;LOAD THE TEMPORARY CODE.
MOVEM P,PSV1# ;SAVE IT.
MOVEM FL,FLSV1#
; MOVE 17,P ;PTR. FOR (UGH! BLETCH!) FOOTRAN PGMS.
;P IS NOW 17 ANYWAY
JRST @(P) ;EXECUTE IT.
INTER2: MOVE P,PSV1 ;RESTORE PUSHDOWN POINTER.
MOVE FL,FLSV1
POP P,0 ;RETRIEVE OLD STG. PTR.
HRRZM JOBFF ;FLUSH THE TEMP. CODE. *****
HRLM JOBSA ;(IT HAS TO GO HERE TOO.) *****
POPJ P, ;LOOK, MA, I'M AN INTERPRETER !!
SUBTTL PLAY Block Processor (PINS)
;THIS CODE READS A NOTE STATEMENT, INITIALIZES THE
; INSTRUMENT, AND GETS IT TURNED ON AT THE RIGHT TIME.
PINS: MOVE A,(A) ;GET STARTING ADDRESSES FOR INSTRUMENT.
PUSH P,(A) ;SAVE THEM.
MOVEI PBASE ;PREPARE TO FILL THE P ARRAY WITH
MOVEM PPTR1# ;THE PARAMETERS TO THE INSTR.
PUSHJ P,SCOMPA ;INIT. COMPLR. FOR POSSIBLE EXPRESSIONS.
MOVE NCHNS ;GET NO. OF OUTPUT CHANNELS.
TLNE -1 ;IS IT FLOATING ?
KIFIX 0,0
PINS2: MOVEM I.NCHNS#
PUSH P,NUMBUC ;SAVE CURRENT STATE OF NUMBER
PUSH P,JOBFF ;BUCKET AND CORE TOP. *****
JRST PINSL ;INIT. THE COMPILER.
PINSL1: CAMN A,COMMAV ;OPTIONAL COMMA BETWEEN PARAMS...
PINSL: PUSHJ P,SCAN
AOS PPTR1 ;INCREMENT P-ARRAY POINTER.
CAMN A,COMMAV ;A COMMA HERE MEANS MISSING
JRST PINSL ;PARAM., SO DON'T CHANGE.
CAMN A,SEMICV ;SEMICOLON ?
JRST PINSB ;YES, END OF PARAMETERS.
TLNE A,SWVBT ;IS IT AN ARRAY NAME?
JRST [ PUSH P,A ;SAVE ARRAY NAME
PUSHJ P,SCAN ;PEEK AT NEXT ELEMENT
CAME A,LPARV ;IS IT A LEFT PAREN?
CAMN A,LFTBRK ;Or left bracket?
JRST [ MOVEM A,SNCHR ;Yes, evaluate it. (SNCHR FOR USE BY EXPR)
POP P,A ;RESTORE THE ARRAY NAME AND COMPILE AN EXPR
JRST PINSL2]
;THE ABOVE IS NOT SUFFICIENTLY GENERAL BUT WILL WORK WITH
;EXISTING FUNCTIONS AND UNIT GENERATORS
POP P,B ;NO, RESTORE THE ARRAY NAME
HRR B,(B) ;GET ITS ADDRESS
HRLI B,INSXR ;TURN ON APPROPRIATE INDEX REGISTER
;FOR UNIT GENERATOR
MOVEM B,@PPTR1 ;SAVE IT
JRST PINSL1] ;AND USE AS FORMAL PARAMETER
PINSL2: PUSHJ P,EXPR ;PARAMETER MAY BE EXPRESSION.
PUSH P,A ;SAVE SCANNED SYMBOL
PUSHJ P,GPONDER ;GET OPERAND POINTER FOR THE EXPR...
TLNE T,SIACBT ;IS VALUE OF EXPR AN AC SYMBOL ?
JRST PINS1 ;YES. IT HAS TO BE CALCULATED.
TLNE T,ARRYBT ;Is it an array reference?
TLNN T,17 ; Yes, if an index is given. Then evaluate it!
JRST PINSL4 ;No, prob. just variable
PUSH P,T ;Emit instruction to get it into an AC
PUSHJ P,GETAC ;Find an AC to put it in
POP P,B ;Will fix array element
MOVE C,[MOVE EMICDI]
PUSHJ P,EMINST ;Emit MOVE
JRST PINSA2 ;Then have it stored in P-ARRAY
PINSL4: POP P,A ;RESTORE SCANNED SYMBOL
PINSL3: MOVE C,(T) ;PICK UP ITS VALUE.
MOVEM C,@PPTR1 ; SO PUT ITS VALUE IN P-ARRAY NOW.
JRST PINSL1
PINS1: ;EXPR. GENERATED SOME CODE, EVIDENTLY.
MOVE A,T ;EMIT AN INSTRUCTION TO STORE THE
PINSA2: MOVE B,PPTR1 ;RESULTANT VALUE IN THE P-ARRAY.
MOVE C,[MOVEM EMICDI]
PUSHJ P,EMINST ;THE CODE WILL GET EXECUTED
PUSHJ P,INTERP ; RIGHT NOW.
PUSHJ P,SCOMPA
POP P,A ;RESTORE SCANNED SYMBOL
JRST PINSL1 ;BACK FOR MORE PARAMS.
; More of PINS
PINSB:
POP OSP,BEGFREE ;FLUSH COMPLR. OUTPUT BUFFERS. *****
POP P,0 ;RECOVER OLD CORE TOP.
MOVEM JOBFF ;RESET THINGS TO FORGET *****
HRLM JOBSA ;ABOUT THE NUMBERS WE DEFINED WHILE *****
POP P,NUMBUC ;SCANNING NOTE PARAMETERS.
MOVE A,SRATE ;GET NO. OF SAMPLES/SEC.
MOVE B,PBASE+1 ;GET STARTING TIME FOR NOTE.
FMPR B,A ;CONVERT TO SAMPLES.
FIXR B,B
MOVEM B,RQ1 ;PLACE AT BOTTOM OF RUN QUEUE.
FMPR A,PBASE+2 ;GET DURATION OF NOTE IN SAMPLES.
FIXR A,A
ADD A,B ;CALC. ENDING TIME OF NOTE.
PUSH P,A ;SAVE SAME.
PUSHJ P,PLAYIT ;PLAY UP TO STARTING TIME OF NOTE.
PLYON: AOS A,RQPTR ;NOW TURN INSTRUMENT ON.
POP P,RQ1(A) ;PUT ENDING TIME IN RUNQUEUE, COL. ONE.
HLRZ T,(P) ;LET'S CHECK TO SEE IF HE'S TRYING TO RUN THE SAME
MOVEM T,LSTINS#
MOVE T,A ;INSTRUMENT AT THE SAME TIME!
PLYON2: SOJL T,PLYON3 ;TEST FOR END OF SEARCH
HRRZ RQ2(T)
CAME LSTINS ;IS IT THE SAME?
JRST PLYON2 ;NO
WARN (You are calling an instrument which is already running!)
COMMENT ⊗ Since the code generated for instruments is non-reentrant,
you should not call it with overlapping time periods as this will
produce unpredicable results. Instead you should make a copy of with
a different name (and different variable names if they are declared outside
that instrument). ⊗;
PLYON3: POP P,T ;GET STARTING ADDR. OF INSTRUMENT.
HLRZM T,RQ2(A) ;PLACE IN RUN QUEUE, COL. TWO.
PUSHJ P,(T) ;EXECUTE THE I-TIME CODE.
JRST PLAY2 ;BACK FOR MORE NOTE STATEMENTS.
DSKDAC: 1
PTERM: PUSH P,A ;HERE AT A 'PLAY' OR 'FINISH'.
MOVSI 200000
MOVEM RQ1 ;SET UP FAKE STARTING TIME.
PUSHJ P,PLAYIT ;FLUSH THE RUN QUEUE.
POP P,A
CAMN A,PLAYV ;WAS IT A 'PLAY' THAT WE SAW ?
JRST PLAY1A ;YES. START NEW SECTION.
MOVE F,PLYOPT
PUSHJ P,@FINTAB(F);NO, A 'FINISH'. EMPTY THE LAST BUFFER
MOVEI [ASCIZ/
/]
JSR TXTOUT
SETZ A,
RUNTIM A,
SUB A,RUNTIM
FSC A,233
FDVRI A,(1000.0) ;CONVERT RUN TIME TO SECONDS
MOVEM A,RUNTIM
PUSHJ P,OUTFLT
TYPSTR [ASCIZ/Seconds run time /]
TIMER 0,
SUB 0,BEGTIM
FSC 0,233
FDVRI 0,(60.0)
MOVE A,RUNTIM
FDVR A,0
FMPRI A,(100.0)
PUSHJ P,OUTFLT
MOVEI [ASCIZ/% PL 1:/]
JSR TXTOUT
MOVE 0,TIME
FSC 0,233
FDVR 0,SRATE
MOVE A,RUNTIM
FDVR A,0
PUSHJ P,OUTFLT
MOVEI [ASCIZ/Compute ratio/]
JSR TXTOUT
OUTPUT TTY, ;FLUSH THE OUTPUT BUFFER
TYPSTR[ASCIZ/
/]
DACLP: JRST CPLAY ; Yes, do it
NONDAC:
SKIPE SAVCNT ;Is it a saved SOUND file?
JRST DELASK ; Yes, ask about deletion
;;; SKIPE NOMAX ;Is it multiple file (i.e. has MAXSMP at end?)
JRST SCHOWN ;YES, WE'RE DONE
DELASK: OUTSTR [ASCIZ/
Do you want to delete your .SAV file?/]
PUSHJ P,ANSWER ;SKIP ON YES REPLY
JRST SCHOWN
INIT SBCHAN,17
SIXBIT/DSK/
0
SYSERR <Can't INIT DSK!>
COMMENT ⊗ An unlikely situation. ⊗;
MOVSI B,SWPTBL ;Copy file name
BLT B,4
LOOKUP SBCHAN,1
JRST[ WARN<Can't find .SAV file>
COMMENT ⊗ Either it has already been deleted or the program goofed in
asking whether you wanted it deleted! ⊗;
JRST SCHOWN ]
RENAME SBCHAN,PZEROS
WARN <Can't delete .SAV file>
COMMENT ⊗ Perhaps someone is referencing it. ⊗;
JRST SCHOWN
; 'PLAYIT' GENERATES SAMPLES BY CALLING THE
; INSTRUMENTS IN THE RUN QUEUE UNTIL IT IS TIME
; TO TURN ON THE INSTRUMENT WHOSE STARTING TIME IS
; IN THE ZEROTH LOCATION OF THE QUEUE, WHEN IT RETURNS.
; INSTRUMENTS ARE TURNED OFF AS REQUIRED.
IOACT←←10000 ;BIT IN DDB INDICATING I/O ACTIVE
PLAYIT: MOVE A,RQPTR ;SEARCH FOR EARLIEST TIME IN QUEUE.
PLYT2: MOVEM A,PTMP# ;SAVE ITS LOCATION.
SKIPA H,RQ1(A) ;PICK IT UP.
CAMG H,RQ1(A) ;A NEW MINIMUM ?
SOJGE A,.-1 ;NO.
JUMPGE A,PLYT2 ;YES.
PLYT1: CAMN H,[XWD 200000,0] ;MIN. FOUND. IS IT THE TERMINATION
POPJ P, ; MARK ? IF YES, THEN RETURN.
SUB H,TIME ;IT'S NOT . CALC. DISTANCE IN FUTURE.
JUMPLE H,PLYT3 ;IF NOT IN FUTURE, FORGET IT.
ADDM H,TIME ;MOVE TIME TO NEW VALUE.
PLYT4: SKIPE OSP,RQPTR ;CYCLE THRU RUNNING INSTRS., IF ANY.
PUSHJ P,@RQ2(OSP) ;CALL AN INSTR.
JFCL 1,.+1
SOJG OSP,.-2 ;CALL THEM ALL.
MOVEI F,1 ;START WITH CHANNEL 1.
PLYT5: SOSLE SBCNT ;COUNT SAMPLE BUFFER COUNTER.
JRST .+4
EXCH F,PLYOPT ;SAVE F AND SET OPTION
PUSHJ P,@OUTTAB(F);FLUSH FULL BUFFER.
EXCH F,PLYOPT ;SAVE OPTION AND RESTORE F
MOVE B,OUTA-1(F) ;PICK UP NEXT CHANNEL'S SAMPLE, AND
FIXR B,B ;It's about time (and it isn't even as good)
CAIN B,400000 ;DON'T OUTPUT TRAILER CODE
ADDI B,1 ;IT'S TOO SMALL ANYWAY...
MOVM A,B ;GET MAGNITUDE...
CAMLE A,MAXSMP ;IS THIS SAMPLE THE BIGGEST YET ?
; MOVEM A,MAXSMP ;YUP.
JRST [ CAMLE A,OVRSMP ;Check for larger than byte size
JRST [ OUTSTR[ASCIZ/Channel /]
MOVE A,F
PUSHJ P,DECPNT
OUTSTR[ASCIZ/ Value /]
MOVE A,OUTA-1(F)
PUSHJ P,OUTFLT
WARN<OUTn too big, clipped> ;Tell loser about it
COMMENT ⊗ Sample just computed was too big to represent in the byte size
currently being used for output. This usually is indicative of some
problem in an instrument. ⊗;
JUMPL B,[MOVN B,OVRSMP
MOVNM B,MAXSMP
JRST .+1 ]
MOVE B,OVRSMP
MOVEM B,MAXSMP
JRST .+1] ;And let him continue
MOVEM A,MAXSMP ;A new MAXSMP
JRST .+1 ]
IDPB B,SBPTR ;PLACE IT IN SAMPLE BUFFER.
SETZM OUTA-1(F) ;ZERO UP THIS CHANNEL'S NEXT SAMPLE
CAMGE F,I.NCHNS ;LAST CHANNEL ?
AOJA F,PLYT5 ;NO. GET OTHER CHANNELS.
MOVE A,@MTSYSA ;GET WORD TO SEE IF WE WANT TO 'INTERRUPT` TO
SOJG H,PLYT4 ;GENERATE REST OF SAMPLES.
PLYT3: SKIPG A,PTMP ;GET PTR. TO NEXT INSTR. OFF OR ON.
POPJ P, ;TIME TO TURN ONE ON.
SOS B,RQPTR ;REMOVE INSTR. FROM QUEUE.
MOVE RQ1+1(B) ;MOVE TOP ENTRY DOWN INTO VACANT
MOVEM RQ1(A) ;SPOT.
MOVE RQ2+1(B)
MOVEM RQ2(A)
JRST PLAYIT ;GO PLAY TILL NEXT EVENT.
SUBTTL UUOSER - User UUO service
BEGIN UUOSER
;Caution: UUO's called by error routine better not use UUOPDL!!!
↑UUOSER: 0
SETOM INUUO
MOVEM P,SAVEP#
LDB P,[POINT 6,40,8] ;GET OPCODE
CAIG P,UUOMAX
JUMPGE P,@UUOTAB(P)
UUOERR: MOVE P,UUOIOWD
PUSH P,UUOSER
OUTSTR [ASCIZ/?ERROR
ILLEGAL USER UUO AT /]
SOS A,UUOSER
HRRZ A,A
PUSH P,A
PUSHJ P,OUTOCT
OUTSTR [ASCIZ/
↑C/]
CALLI 1,12
MOVE P,SAVEP
SETZM INUUO
POPJ P,
UUORET: MOVE P,SAVEP
SETZM INUUO
JRSTF @UUOSER
;TYPCHR AND TYPSTR --- TYPE A CHARACTER AND TYPE A STRING
↑.TYPCHR: MOVE P,@40 ;THESE ARE SO THAT A DIFFERENT DEVICE
SOSGE TOB+2 ;THAN TTY COULD BE USED.
OUTPUT TTY,
IDPB P,TOB+1
JRST UUORET
↑.TYPSTR: MOVEI P,440700
HRLM P,40
TYPST2: ILDB P,40
JUMPE P,[ OUTPUT TTY,
JRST UUORET]
SOSGE TOB+2
OUTPUT TTY,
IDPB P,TOB+1
JRST TYPST2
;BLAST --- Type string on colsole or other console of same programmer
;↑.BLAST:MOVEM 0,SAVE0#
; SETO 0,
; TTYUUO 6,0
; JUMPG 0,[OUTSTR @40
; MOVE 0,SAVE0
; JRST UUORET]
; MOVE P,UUOIOWD
; GETPPN 0,
; HRRZ 0,
; PUSH P,0
; PUSH P,0
; PUSH P,[[ASCIZ/;;Message from Music Program: /]]
; PUSHJ P,BLAST↑
; PUSH P,40
; PUSHJ P,BLAST↑
; MOVE 0,SAVE0
; JRST UUORET
↑.ERRUUO:MOVE P,SAVEP
BEND UUOSER
JSR SAVE
MOVE P,UUOIOWD
LDB 15,[POINT 4,40,12]
CAILE 15,11
SETZ 15,
OUTSTR@[[ASCIZ/Dryrot: /] ;0
[ASCIZ/Error: /] ;1
[ASCIZ/Warn: /] ;2
[ASCIZ/Warn: /] ;3
[ASCIZ/Unexpect error, may be problem with system: /] ;4
[ASCIZ/Dryrot: /] ;5 ;UNDEFINED AC FIELD
[ASCIZ/Dryrot: /] ;6 ;UNDEFINED AC FIELD
[ASCIZ/Dryrot: /] ;7 ;UNDEFINED AC FIELD
[ASCIZ/Debug: /] ;10
[ASCIZ/Debug: /] ;11
](15)
OUTSTR @40
SETOM INERR#
MOVE 1,UUOSER
SETZM INUUO
MOVEM 1,ERRPC
ERR7: JSR ERR2
CAIN 15,3 ;Skip warning?
AOSA ERRPC
CAIN 15,2 ;Non-skip warning
TDZA 15,15
SETO 15,
MOVEM 15,WARNFL#
JSR RESTORE
SETZM INUUO
JRST ERR99
;;;↑INTERR: SKIPE INERR ;Are we already losing?
;;; JRST BADERR ;Yes, give up
;;; SETOM INERR ;Don't allow two errors
;;; JSR SAVE
;;; MOVE 15,IWARN
;;; MOVEI 1,ERR7
;;; EXCH 1,INTPC
;;; MOVEM 1,ERRPC
;;; INTJEN INTBIT
;;;BADERR: OUTSTR[ASCIZ/
;;;Already in error routine. I give up!/]
;;; EXIT 1,
;;; INTJEN INTBIT ;Cross your fingers...
UUOPDL: BLOCK 20
UUOIOW: IOWD .-UUOPDL,UUOPDL
SUBTTL Error Handling Routines.
EXTERNAL JOBOPC
INTEGER INUUO,INERR,LINCNT,PAGCNT,LINENO,NXTPAG,NXTLIN,NO.MSG,ERRPC,IWARN
COMMENT ⊗
↓INUUO: 0
↓LINCNT: 0
↓PAGCNT: 0
↓LINENO: 0
↓NXTPAG: 377777
↓NXTLIN: 377777
↓NO.MSG: 0
; 0 ;TO TERMINATE OUTSTR
⊗;
ERR99: MOVE 1,WARNFL
OUTSTR @1+[[ASCIZ/??/]
[ASCIZ/→→/]
[0]
[ASCIZ/↔/]](1)
SKIPG WARNFL ;GO DIRECTLY TO ERR96 IF NOT DEBUGGING
JRST ERR96
SOSN WARNFL ;DON'T STOP FOR DEBUG MODE 1
JRST ERR97
ERR96: CLRBFI ;CLEAR TTY INPUT BUFFER
SETOM TTYWRD# ;ARE WE AT AN III OR DD
TTYUUO 6,TTYWRD
AOS TTYWRD ;So we don't DPYOUT to detached tty's
SKIPGE TTYWRD
DPYOUT 17,ERRDPY ;YES, DISPLAY PROMPTS
INCHWL 1
SKIPGE TTYWRD
DPYOUT 17,[.+1 ;FLUSH DISPLAY
0]
CLRBFI
CAIN 1,"α"
JRST ERR97 ;ALWAY CONTINUE!
CAIL 1,"a" ;FOR LOWER CASE
SUBI 1,40 ;CONVERT TO UPPER CASE
CAIN 1,"E"
JRST GOEDIT
;; CAIE 1,"D" ;DEBUG?
;; JRST ERR98 ;NO
;; SKIPE JOBDDT ;YES, MAKE SURE IT'S LOADED
;; JRST .+3
;; OUTSTR [ASCIZ/NO DDT/];NOT LOADED, PRINT MESSAGE
;; JRST ERR99
;; MOVE 1,ERRPC
;; MOVEM 1,JOBOPC
;; JRST DDTGO2
;;DDTGO: POP P,JOBOPC ;FOR RAID'S USE
;; SOS JOBOPC
;;DDTGO2: MOVE 1,ERSVAC+1
;; SETZM INERR
;; JRST @JOBDDT
ERR98: CAIN 1,"S" ;RESTART?
JRST GO ;YES, RESTART
CAIN 1,"R" ;RETRY?
JRST [RETRY: MOVEI FL,RESTART
MOVEI 1
MOVEM RECCT ;SET USETI COUNT
MOVEM PAGCNT ;SET PAGE COUNT
MOVEM LINCNT ;SET PAGE COUNT
PUSHJ P,SETUP ;USE SAME FILE
SETZ FL,
JRST GOB] ;DO RESTART
SKIPL WARNFL ;CAN WE PROCEED
CAIE 1,15
JRST [ OUTSTR [ASCIZ/??/]
OUTSTR ERRERR
OUTSTR [ASCIZ/
Which do you want?/]
JRST ERR96]
ERR97: MOVE 1,ERSVAC+1
C.:
DPYCLR
SETZM INERR
JRSTF @ERRPC
ERRDPY: .+2
ERRLEN
0
36032146 ;LVW 0,740,6,4,ABS,INV
ERRERR:
ASCID/
S - Restart, R - Retry with same file,
E - Edit , <return> - Continue/
0
ERRLEN←←.-ERRDPY-2
ERSVAC: BLOCK 20
ERR2: 0 ;ERROR MESSAGE PRINTER.
OUTSTR [ASCIZ/ Line = /]
MOVE A,LINCNT
SKIPE LINENO
OUTSTR LINENO ;FOR SOS FLAVOR OF LINE NUMBERS
SKIPN LINENO
PUSHJ P,OUTFLT
OUTPUT TTY,
OUTCHR ["/"]
MOVE A,PAGCNT
PUSHJ P,OUTFLT
OUTSTR [ASCIZ/
/];
; FIND OFFENDING LINE
SKIPE NOISCP ;Check for ISCP invalid
JRST ERR2Z
MOVE A,ISCP ;SET UP THREE POINTERS TO BEGINNING OF TEXT BUFFER
MOVE B,A ;TO BE USED TO FIND LINES PRECEDING ERROR
MOVE C,B
ERR2B: ILDB A ;SEARCH UNTIL <CR>
CAIE 15
JRST ERR2A
MOVE C,B ;<CR> FOUND, NOW REMEMBER WHERE IT IS
MOVE B,A
ERR2A: CAME A,SCP ;WAS IT WHERE WE FOUND THE ERROR?
JRST ERR2B ;NO, TRY AGAIN
JRST ERR2D ;YES, LET'S PRINT IT, STARTING THE PREVIOUS LINE
ERR2C: OUTCHR
ERR2D: ILDB C ;GET A CHARACTER
CAME C,SCP ;WAS IT WHERE THE ERROR WAS?
JRST ERR2C ;NO, PRINT IT AN GET ANOTHER
CAIE 14 ;DON'T OUTPUT FORM FEED!
OUTCHR ;PRINT IT TOO
ERR2E: SKIPN (A) ;AT END OF BUFFER?
JRST ERR2G ;YES
ILDB A
OUTCHR
CAIE 15
JRST ERR2E
ERR2G: OUTSTR [ASCIZ/
/]
CAMN B,SCP
JRST ERR2H
ERR2F: ILDB B ;NOW POINT TO ERROR
CAMN B,SCP ;AT ERROR?
JRST ERR2H ;YES, PRINT '↑` AND RETURN
JUMPE ERR2F ;IGNORE NULLS
CAIN 12
JRST ERR2F
CAIN 15
JRST .+3
CAIE 11 ;A TAB?
MOVEI " " ;NO, OUTPUT A SPACE THEN
OUTCHR
JRST ERR2F ;NO, TRY AGAIN
ERR2H: OUTCHR ["↑"]
ERR2Z: OUTSTR [ASCIZ/
/]
JRST @ERR2
;SAVE AND RESTORE ACS FOR ERROR ROUTINES
SAVE: 0
MOVEM 17,ERSVAC+17 ;SAVE AC'S
MOVEI 17,ERSVAC
BLT 17,ERSVAC+16
MOVE 17,ERSVAC+17
JRST @SAVE
RESTORE:0
MOVSI 17,ERSVAC ;RESTORE AC'S.
BLT 17,17
JRST @RESTORE
; HERE INVOKE RPG!!!
;;;CMDEDT: OUTSTR [ASCIZ/File = /]
;;; PUSH P,[DNAM]
;;; PUSH P,[INCHWL 1]
;;; PUSH P,[0]
;;; PUSHJ P,RDIOSP
;;; JRST SCHOWN
;;; PUSHJ P,IGNOLF
;;; MOVEI 1,"E"
GOEDIT: HLRZ DNAM
CAIE 'DSK'
JRST [ OUTSTR [
ASCIZ/I don't think our editors will work if it's not on the DSK!
/]
JRST ERR96]
INIT 17,17
SIXBIT/DSK/
0
SETZM QQFILE+3 ;CLEAR THE PPN
GOEDI1: ENTER 17,[QQFILE: SIXBIT/QQSVCM/
SIXBIT/RPG/
0
0]
JRST [ OUTSTR [ASCIZ/Can't write QQSVCM.RPG!
/]
JRST 4,GOEDI1]
OUTPUT 17,[ IOWD QQLEN,QQMSG
0]
CLOSE 17,
MOVE 14,DLK ;GET FILENAME
HLLZ 13,DLK+1 ;EXTENSION
MOVE 11,DLK+4 ;PPN
SKIPN 15,LINENO ;LINE NUMBER?
MOVE 15,LINCNT ;NO, GET LINE COUNT THEN
MOVE 16,PAGCNT ;PAGE NUMBER
SKIPE LINENO ;IS IT AN SOS FILE?
SKIPA 2,[SIXBIT/SOS/] ;YES, IT HAS LINE NUMBERS
MOVSI 2,'E ' ;NO, ASSUME IT'S A TV FILE
MOVEM 2,TOEDIT+1
MOVE [XWD EDSWAP,TOEDIT]
SWAP
JRST 4,.-1
EDRET: JFCL
INIT 17,17 ;FLUSH RPG'S CONTRIBUTION TO DISK SPACE
SIXBIT/DSK/
0
SETZM QQQQ+3
LOOKUP 17,[QQQQ: SIXBIT/QQQQMU/
SIXBIT/RPG/
0
0]
JRST EDRET2
RENAME 17,PZEROS
JFCL
EDRET2: MOVEI GO ;RESET JOBSA
HRRM JOBSA
MOVE P,[IOWD LPLIST,PLIST] ;GET A PDL
MOVE [SIXBIT/MUSIC/]
SETNAM ;SET NAME TO MUSIC
JRST RETRY ;WE'RE OFF AGAIN!
TOEDIT: SIXBIT /SYS/
SIXBIT /TV/
SIXBIT /DMP/
1
0
EDSWAP: SIXBIT /DSK/ ;DEVICE FOR SWAP
SIXBIT /QQMUS/ ;FOR FILENAME
SIXBIT /RPG !/ ;FILENAME.SAV (SAVE SEGMENT ALSO)
EDRET ;CORE SIZE (0=USE WHAT YOU NEED)
0 ;END OF LIST (PPN)
QQMSG: ASCIZ|COM QQMUS.RPG/NON QQMUS.RPG|
QQLEN←←.-QQMSG
IGNOLF: CAIN 0,15
INCHRS 0
POPJ P,
POPJ P,
; Illegal array reference routine
; PRINTS OUT ARRAY NAME AND SUBSCRIPT VALUE
ILLARF: OUTPUT TTY, ;FLUSH TTY BUFFER
OUTSTR [ASCIZ/
Subscript of out bounds for array /]
JSR SAVE ;SAVE THE AC'S
MOVE A,@(P) ;GET POINTER TO GOODBITS WORD
PUSHJ P,PRNTSYM
TYPSTR [ASCIZ/, subscript = /]
JSR RESTORE
PUSH P,A
LDB A,[POINT 4,@-1(P),(17-5)]
MOVE A,ERSVAC(A)
POP P,(P)
ILLAR2: PUSHJ P,OUTFLT
SETOB 1,WARNFL
JRST ERR99
;P array error
BADARR: OUTPUT TTY, ;Flush TTY buffer
ERROR <Array expected in function or U.G. call, but number found instead.
Prob. argument to instrument wrong.>
COMMENT ⊗ Either a function or Unit Generator was called with a Pn symbol, which
should have be an array, but instead a floating point number was found. This
is usually caused by passing a number instead of an array in an instrument
call, or an error in the instrument with respect to the numbering of the
Pn arguments. ⊗;
SUBTTL Miscellaneous Cruft
UDIERR: ERROR (Undefined IDENTIFIER)
SILCH: WARN (Illegal character)
COMMENT ⊗ A character was found in file which has no meaning to the compiler. ⊗;
POPJ P, ;I HOPE THIS WORKS, IT MIGHT NOT
SNUMX1: ERROR (Illegal character in number);⊗ Not a digit or decimal point. ⊗;
FNDWV: PUSHJ P,DRYROT
↑PI: 3.14159265359;*RANDOM CONSTANTS- IS THERE A BETTER PLACE FOR THIS?
.SKIP.↑: 0 ;So as to avoid UNDEF EXTERNAL FROM FINC!
FOR @$ A IN (PW,COMM,EXP,ENDS,WHLS)
<A$OP: PUSHJ P,DRYROT
>
; *** WHERE ELSE SHOULD THIS GO?? ***
; DECIDES IF A SYMBOL IS A PROPER STATEMENT TERMINATOR AND SKIPS IF
; IT IS NOT A TERMINATOR
STMTRM: CAME A,SEMICV ;';`
CAMN A,ENDV ;OR 'END`
POPJ P,
CAME A,ELSEV ;OR 'ELSE`
CAMN A,UNTILV ;OR 'UNTIL`
POPJ P,
AOS (P)
POPJ P,
SUBTTL Lookup External in DDT Symbol Table
SYMSCH: MOVEI T,6 ;LOOK UP EXTERNAL SYMBOL.
MOVE [POINT 6,ACCUM,5] ;PREPARE TO CONVERT TO
MOVEI B,0
SYMS1: ILDB A,0 ;RADIX 50.
JUMPE A,SYMS4
CAIN A,16
MOVEI A,73
CAIG A,5
ADDI A,70
CAIGE A,32
ADDI A,7
IMULI B,50
ADDI B,-26(A)
SOJG T,SYMS1
SYMS4: TLO B,40000
MOVE A,116
SYMS3: AOBJP A,SYMS2
CAME B,-1(A)
AOBJN A,SYMS3
SYMS2: SKIPL A ;Is it present?
POPJ P, ; No, non-skip return means failure
HRRZ A,(A) ;Flush crud in left half
AOS (P) ;Skip return for success
POPJ P,
;NX: 0
; ERROR (Missing External function)
;COMMENT ⊗ Either an external function was not loaded or its name was misspelled.⊗;
; JRST INTER2
SUBTTL Unit Generators
;; HERE ARE SOME WONDERFUL UNIT GENERATORS.
BEGIN U.G.
COMMENT ⊗
CALLED WITH:
JSP RA,OSCIL
<Amplitude> ;0 (-5)
<Increment> ;1 (-4)
<Array>(INSXR) ;2 (-3)
<Temp - Sum> ;3 (-2)
⊗;
↑OSCIL: MOVE INSXR,3(RA)
KIFIX INSXR,INSXR
TRZE INSXR,777000
JSP T1,OSCIL1
MOVE T,@2(RA)
FMPR T,@(RA)
SKIPGE T1,@1(RA) ;OSCIL DOESN'T WANT NEG. INC.
JRST [ WARN (NEGATIVE INC. TO OSCIL)
COMMENT ⊗ OSCIL is not defined to go accept a negative increment however if
you continue from this error it will treat this increment as a NOSCIL does. ⊗;
JRST OSCILX]
OSCILX: FADM T1,3(RA)
JRST 4(RA)
↑NOSCA: ADDI RA,1 ;SEE INOSCA
↑NOSCIL:MOVE INSXR,3(RA) ;SAME AS OSCIL EXCEPT IT WILL TAKE NEG. INC
KIFIX INSXR,INSXR
TRZE INSXR,777000
JSP T1,OSCIL1
MOVE T,@2(RA)
FMPR T,@(RA)
MOVE T1,@1(RA)
FADM T1,3(RA)
JRST 4(RA)
OSCIL1↑:MOVSI (-512.0) ;WRAP AROUND THE POINTER.
JUMPGE INSXR,.+2
MOVNS 0 ;IF NEG. INC., WRAP AROUND OTHER WAY.
FADM 3(RA)
HRLI INSXR,0 ;INSERTED 1/25/71 TO ALLOW ZOSCIL=NOSCIL
JRST (T1)
↑OUT: 0 ;FUNCTION OUT(VALUE); BEGIN OUTA←OUTA+VALUE; END
MOVE @(RA) ;PICK UP INPUT.
FADM OUTA ;ACCUMULATE INTO OUTPUT ARRAY.
POPJ P, ;RETURN FROM INSTRUMENT.
↑OUT2: 0 ;FUNCTION OUT(X,CH1,CH2);
MOVE @(RA) ; BEGIN OUTA←OUTA+X*CH1; OUTB←OUTB+X*CH2; END
MOVE 1,0
FMP 0,@1(RA)
FADM 0,OUTA ;
FMP 1,@2(RA)
FADM 1,OUTB
POPJ P,
↑EXPEN: MOVE INSXR,@1(RA) ;GET INCREMENT.
FADB INSXR,3(RA) ;INCREMENT POINTER.
KIFIX INSXR,INSXR
CAIL INSXR,777 ;IF GREATER THAN 511, STICK
EXPEN2: MOVEI INSXR,777 ;AT LAST ELEMENT OF ARRAY. (ALSO COMES HERE FROM ZEXPEN)
MOVE T,@2(RA) ;GET ARRAY ELEMENT.
FMPR T,@(RA) ;MULTIPLY BY AMPLITUDE.
JRST 4(RA) ;RETURN.
COMMENT ⊗
CALLED WITH:
JSP RA,VFMULT
<Amplitude> ;0
<Position> ;1
<Array>(INSXR) ;2
⊗;
VFM2: FSBR INSXR,[512.0] ;YOU MUST NOW SET PTR FOR VFMULT!
MOVEM INSXR,@VFMULT
↑VFMULT: MOVE INSXR,@1(RA) ;GET POINTER INPUT.
CAML INSXR,[512.0]
JRST VFM2
KIFIX INSXR,INSXR
MOVE T,@2(RA) ;GET INDICATED ELEMENT OF ARRAY.
FMPR T,@(RA) ;MULT. BY AMPLITUDE.
JRST 3(RA)
COMMENT ⊗ NOSCA
JSP RA,NOSCA
<Initial sum> ;-1(-6)
<Ampiltude> ;0 (-5)
<Increment> ;1 (-4)
<Array>(INSXR) ;2 (-3)
<Temp - Sum> ;3 (-2)
⊗;
↑INOSCA: 0
MOVE T,(RA)
MOVE T1,@-6(T)
MOVEM T1,-2(T)
JRA RA,1(RA)
COMMENT ⊗ INTRP
JSP RA,INTRP
<Value 1> ;-1(-6)
<Value 2> ;0 (-5)
<Temp - Increment> ;1 (-4)
<Array>(INSXR) ;2 (-3)
<Temp - sum> ;3 (-2)
⊗;
↑INTRP: ADDI RA,1 ;TO KEEP OSCIL1 HAPPY (CHANGE THIS SOMEDAY)
MOVE INSXR,3(RA) ;GET INDEX IN ARRAY
KIFIX INSXR,INSXR ;MAKE AN INTEGER
TRZE INSXR,777000 ;DID IT WRAP AROUND?
JSP T1,OSCIL1 ;YES, BUT IT REALLY SHOULDN'T!!!!
MOVE T,@2(RA) ;GET ARRAY ELEMENT
MOVE @(RA) ;GET FIRST VALUE
FSBR @-1(RA) ;SUBTRACT THE SECOND
FMPR T,0 ;MULIPLY ARRAY ELEMENT BY DIFFERENCE
FADR T,@-1(RA) ;AND ADD THE FIRST VALUE
MOVE T1,1(RA) ;NOW UPDATE THE SUM
FADM T1,3(RA)
JRST 4(RA)
↑IINTRP: 0
MOVE T,(RA) ;GET INDEX TO ARGUMENT LIST
; MOVE T1,@-6(T) ;GET DIFFERENCE BETWEEN TWO
; FSBR T1,@-7(T)
; MOVEM T1,-2(T) ;SAVE IN TEMP
;**** THIS DIDN'T WORK IF THE TWO VALUES ARE TO BE CALCULATED AT R-TIME!!!!
MOVSI T1,(512.0) ;NOW CALCULATE THE INCREMENT BASED ON THE
FDVR T1,SRATE ;DURATION OF THE NOTE
FDVR T1,PBASE+2
MOVEM T1,-4(T) ;SAVE IN ANOTHER TEMP
JRA RA,1(RA)
; ZOSCIL Family of Unit Generators
COMMENT ⊗ ZOSCIL - Called with
JSP RA,ZOSCIL
<Amplitude> ;0
<Increment> ;1
<Array> ;2
<Zeroed-Sum> ;3
⊗;
↑ZOSCA: ADDI RA,1
↑ZOSCIL: MOVE INSXR,3(RA) ;ZOSCIL WORKS LIKE COSCIL AND NOSCIL!
KIFIX INSXR,INSXR
TRZE INSXR,777000 ;DID WE RUN OVER?
JSP T1,ZOSCL1 ;YES, DO WRAPAROUND
MOVE T,@2(RA) ;PICK UP FIRST ELEMENT
move insxr ;SAVE INDEX
move t1,t ;COPY FIRST ELEMENT
cain insxr,777 ;ARE WE AT THE LAST ELEMENT
tdza insxr,insxr ;YES, SET INDEX TO ZERO AND SKIP
addi insxr,1 ;NO, INCREMENT INDEX
fsbr t1,@2(ra) ;GET DWFFERENCE IN VALUE I
fsc 233 ;(FLOAT THE INDEX)
fsb 3(ra) ;GET DIFFERENCE IN INDEX INTO 0
fmpr t1,0 ;THE PRODUCT OF THE ABOVE TWO DIFFERENCES
fadr t,t1 ;IS ADDED TO THE FIRST ELEMENT
FMPR T,@(RA) ;SCALED BY AMPLITUDE
MOVE T1,@1(RA) ;UPDATE SUM OF INCREMENTS
FADM T1,3(RA)
JRST 4(RA)
ZOSCL1: MOVSI (-512.0) ;WRAP AROUND THE POINTER.
JUMPGE INSXR,.+2
MOVNS 0 ;IF NEG. INC., WRAP AROUND OTHER WAY.
FADB 0,3(RA) ;Update pointer
KIFIX INSXR,0 ;Fix it again and check range
TRZN INSXR,777000 ;Better be between 0 and 511
JRST (T1)
JRST ZOSCL1 ;Still out of range, try again
↑ZEXPEN: SKIPGE INSXR,3(RA) ;ZEXPEN WORKS LIKE ZOSCIL AND EXPEN!
JRST [ WARN (Negative increment to ZEXPEN)
COMMENT ⊗ ZEXPEN is undefined for negative increments however if you contiune
it will treat it like a ZOSCIL.⊗;
JSP T1,OSCIL1 ;DO WRAPAROUND ANYWAY
JRST .+1] ;LET THE LOSER CONTINUE
KIFIX INSXR,INSXR
CAIL INSXR,777 ;IF GREATER THAN 511, STICK
JRST EXPEN2 ;AT LAST ELEMENT (WE WON'T NEED TO INTERPOLATE)
MOVE T,@2(RA) ;PICK UP FIRST ELEMENT
move insxr ;SAVE INDEX
move t1,t ;COPY FIRST ELEMENT
addi insxr,1 ;NO, INCREMENT INDEX
fsbr t1,@2(ra) ;GET DWFFERENCE IN VALUE I
fsc 233 ;(FLOAT THE INDEX)
fsb 3(ra) ;GET DIFFERENCE IN INDEX INTO 0
fmpr t1,0 ;THE PRODUCT OF THE ABOVE TWO DIFFERENCES
fadr t,t1 ;IS ADDED TO THE FIRST ELEMENT
FMPR T,@(RA) ;SCALED BY AMPLITUDE
MOVE T1,@1(RA) ;UPDATE SUM OF INCREMENTS
FADM T1,3(RA)
JRST 4(RA)
COMMENT ⊗ ZINTRP
JSP RA,ZINTRP
<Value 1> ;-1(-6)
<Value 2> ;0 (-5)
<Temp - Increment> ;1 (-4)
<array>(INSXR) ;2 (-3)
<Temp - sum> ;3 (-2)
⊗;
↑ZINTRP: ADDI RA,1 ;AN INTERPOLATING INTRP!
MOVE INSXR,3(RA)
KIFIX INSXR,INSXR
TRZE INSXR,777000 ;DID WE RUN OVER?
JSP T1,ZOSCL1 ;YES, DO WRAPAROUND (BUT IT REALLY SHOULDN'T!)
MOVE T,@2(RA) ;PICK UP FIRST ELEMENT
move insxr ;SAVE INDEX
move t1,t ;COPY FIRST ELEMENT
cain insxr,777 ;ARE WE AT THE LAST ELEMENT
tdza insxr,insxr ;YES, SET INDEX TO ZERO AND SKIP
addi insxr,1 ;NO, INCREMENT INDEX
fsbr t1,@2(ra) ;GET DIFFERENCE IN VALUE I
fsc 233 ;(FLOAT THE INDEX)
fsb 3(ra) ;GET DIFFERENCE IN INDEX INTO 0
fmpr t1,0 ;THE PRODUCT OF THE ABOVE TWO DIFFERENCES
fadr t,t1 ;IS ADDED TO THE FIRST ELEMENT
MOVE @(RA) ;GET SECOND VALUE
FSBR @-1(RA) ;SUBTRACT THE FIRST
FMPR T,0 ;MULIPLY BY DIFFENCE BETWEEN TWO VALUES
FADR T,@-1(RA) ;AND ADD TO THE FIRST VALUE
MOVE T1,1(RA) ;UPDATE SUM OF INCREMENTS
FADM T1,3(RA)
JRST 4(RA)
; More generators, LINEN
COMMENT ⊗ Called with:
JSP RA,LINEN
<Temp - Increment for attack> ;0 (-14)
<Temp - Incrememt for middle> ;1 (-13)
<Temp - Increment for decay> ;2 (-12)
<Amplitude> ;3 (-11)
<Attack time in seconds> ;4 (-10)
<decay time in seconds> ;5 (-7)
<Duration in seconds> ;6 (-6)
<Array>(INSXR) ;7 (-5)
<Sum of increments (not temp)> ;10 (-4)
<Zeroed - Current increment > ;11 (-3)
<Zeroed - End of section of array>;12(-2)
⊗;
↑LINEN: MOVE INSXR,11(RA) ;GET INCREMENT.
; FADB INSXR,10(RA) ;ADD TO POINTER.
JUMPL INSXR,[ WARN (Negative increment to LINEN)
COMMENT ⊗ LINEN is undefined for negative increments. The results may be
unpredicatable. Probably means that the attack time plus the decay time
exceeds the duration. ⊗;
JRST LINEN4-1]
FADB INSXR,@10(RA) ;NOW YOU MUST RESET PTR
LINEN4: CAML INSXR,12(RA) ;ARE WE PAST END OF SECTION ?
JRST LINEN2 ;YES.
KIFIX INSXR,INSXR
MOVE T,@3(RA) ;AMPLITUDE.
FMPR T,@7(RA) ;MULT. BY ARRAY ELEMENT.
JRST 13(RA) ;RETURN.
LINEN2: MOVE T,12(RA) ;PICK UP CURRENT LIMIT.
FDVRI T,(<128.0>)
KIFIX T,T
CAIL T,3 ;END OF ARRAY ?
JRST LINEN3 ;YES.
HRLI T,RA ;PREPARE FOR INDEXING...
MOVE @T ;PICK UP NEXT INCREMENT.
MOVEM 11(RA) ;PUT AWAY.
MOVSI (128.0)
FADM 12(RA) ;INCREMENT LIMIT TO NEXT VALUE.
JRST LINEN4
LINEN3: MOVEI 14(RA) ;FAKE UP A PARAMETER FOR LINEN1.
MOVEM .+2
JSA RA,LINEN1 ;RE-INITIALIZE THE GENERATOR.
0 ;
; SETZM 10(RA) ;RESET PTR.
SETZM @10(RA) ;NOW YOU MUST RESET PTR
SETZM 11(RA) ;AND INCREMENT.
SETZM 12(RA) ;...AND LIMIT.
JRST LINEN
↑LINEN1: 0 ;THE INITIALIZING CODE FOR LINEN.
MOVE T2,(RA) ;GET POINTER TO END OF PARAMETERS.
MOVE T1,[1.0] ;CALC. 128*(SECONDS/SAMPLE)
FDVR T1,SRATE
FSC T1,7
MOVE T,@-10(T2) ;GET RISE TIME IN SECONDS.
FDVRM T1,T ;INCREMENT←T1/TIME (=128/(TIME IN SAMPS))
MOVEM T,-14(T2) ;PLACE IN PARAMETER 0.
MOVE T,@-6(T2) ;DURATION OF NOTE IN SECONDS...
FSBR T,@-7(T2) ;...MINUS FALL TIME..
FSBR T,@-10(T2) ;...MINUS RISE TIME.
FDVRM T1,T ;CHANGE TO INCREMENT.
MOVEM T,-13(T2) ;PLACE IN PARAMETER 1.
FDVR T1,@-7(T2) ;INCREMENT FOR FALL TIME.
MOVEM T1,-12(T2) ;PLACE IN PARAMETER 2.
JRA RA,1(RA)
↑VALUE: MOVE T,@(RA) ;DUMMY UNIT GENERATOR... OUTPUT IS
JRST 1(RA) ;SAME AS ITS PARAMETER.
; Reverberation Unit Generators
; REV1 IS THE SIMPLE FED-BACK DELAY LOOP, OR 'COMB FILTER'.
COMMENT ⊗ Called with:
JSP RA,REV1
<Input to reverberator> ;0 (-7)
<Delay length> ;1 (-6)
<Gain> ;2 (-5)
<Array>(INSXR) ;3 (-4)
<Temporary - Array pointer> ;4 (-3)
<Temp. - Int. Length of array> ;5 (-2)
⊗;
↑REV1: AOS INSXR,4(RA) ;INCREMENT OUTPUT PTR.
CAML INSXR,5(RA) ;IS IT TIME TO WRAP AROUND ?
SETZB INSXR,4(RA) ;YES.
MOVE 1,@3(RA) ;GET OUTPUT OF DELAY LINE.
MOVE 2,1 ;LEAVE IN 1 AS FINAL OUTPUT.
FMPR 2,@2(RA) ;MULTIPLY BY FEEDBACK GAIN.
REVA: MOVE @1(RA) ;GET DELAY TIME, T.
KIFIX 0,0
ADD INSXR,0 ;MOVE PTR. AROUND TO INPUT END.
CAML INSXR,5(RA) ;PROBABLY HAVE TO WRAP AROUND..
SUB INSXR,5(RA) ;YUP. SUBTRACT LENGTH OF DELAY ARRAY.
FADR 2,@(RA) ;ADD IN THE INPUT SAMPLE.
JFCL 1,[SETZB 2,1 ;FLOAT. UNDER FLOW
SETOM FXUFLG#
JRST .+1]
MOVEM 2,@3(RA) ;PLACE IN INPUT OF DELAY LINE.
JRST 6(RA) ;RETURN.
;REV2 IS THE ALL-PASS REVERBERATOR.
COMMENT ⊗ Called with:
JSP RA,REV2
<Input to reverberator> ;0 (-7)
<Delay length> ;1 (-6)
<Gain> ;2 (-5)
<Array>(INSXR) ;3 (-4)
<Temporary - Array pointer> ;4 (-3)
<Temp. - Integer form of 1(RA)> ;5 (-2)
⊗;
↑REV2: AOS INSXR,4(RA) ;CALC. PTR. AS IN REV1.
CAML INSXR,5(RA)
SETZB INSXR,4(RA)
repeat 0,< ; Comment out to make way for new reverberator
MOVN 1,@3(RA) ;GET NEGATIVE OF OUTPUT OF DELAY.
MOVN 0,@2(RA) ;ALSO NEGATIVE OF GAIN, G.
FMPR 1,0 ;FORM GAIN*OUTPUT
MOVE 2,1 ;(NOTE THIS IS POSITIVE).
FMPR 1,0 ;FORM -G↑2 * OUTPUT.
FADR 1,@3(RA) ;(1-G↑2) * OUTPUT.
FMPR 0,@(RA) ;FORM -G * INPUT.
FADR 1,0 ;FINAL OUTPUT IS -G*IN +(1-G↑2)*OUT.
> ; Ends repeat 0 above (JAM 10/28/75)
COMMENT ⊗ ; KS 13-May-1977 substitute lattice form, eliminate a multiply!
MOVN 1,@2(RA) ; PICK UP NEGATIVE OF GAIN, G.
FMPR 1,@(RA) ; ACCUMULATE -G*INPUT
MOVE 2,@3(RA) ; PICK UP OUTPUT OF DELAY
FADRB 1,2 ; TOTAL OUTPUT IS OUT-G*INPUT
FMPR 2,@2(RA) ; FEED G*TOTAL OUTPUT BACK INTO DELAY
⊗ ; KS -- End of JAM's substitution, start of mine
MOVN 2,@(RA) ; PICK UP NEGATED INPUT
FADR 2,@3(RA) ; ADD IN DELAYED SIGNAL
FMPR 2,@2(RA) ; MULTIPLY IN GAIN
MOVE 1,@3(RA) ; GET DELAYED SIGNAL AGAIN
FADR 1,2 ; COMBINE WITH ATTENUATED (INPUT+DELAYED SIGNAL)
; KS -- End of my substitution
JRST REVA ;FROM HERE ON, SAME AS REV1.
; THIS IS THE I-TIME CODE FOR DELAY, REV1 AND REV2.
↑REVI: HRRZ T1,(RA) ;GET PTR. TO END OF REV PARAMS.
MOVNI INSXR,1 ;INSXR←-1
HRRZ @-4(T1) ;GET -1ST ELEMENT OF ARRAY (THE LENGTH)
MOVEM -2(T1) ;PLACE IN THE SECOND DUMMY PARAM.
MOVE T,@-6(T1) ;CHECK FOR ILL ARRAY REF.
KIFIX T,T
CAMGE 0,T
JRST [ MOVNI INSXR,3 ;INSXR←-3
MOVE @-4(T1)
PUSHJ P,ILLARF ;OOPS!
JUMP T,@0
JRST .+1 ]
SKIPN REVINI ;SHOULD WE INIT. THE DELAY ARRAY ?
JRST 1(RA) ;NO.
SETZM -3(T1) ;YES. FIRST CLEAR THE POINTER LOC.
HRRZ T,-4(T1) ;GET PTR. TO ARRAY.
↑REVI2: ADDI -1(T) ; 0 NOW POINTS TO TOP OF ARRAY.
HRL T,T
SETZM (T) ;CLEAR FIRST ELEMENT OF ARRAY.
ADDI T,1 ;FORM BLT POINTER.
BLT T,@0 ;CLEAR REST OF ARRAY.
JRST 1(RA)
; DELAY IS THE SIMPLE DELAY
COMMENT ⊗ Called with:
JSP RA,DELAY
<Input to reverberator> ;0 (-7)
<Delay length> ;1 (-6)
<Temporary - for compatability> ;2 (-5)
<Array>(INSXR) ;3 (-4)
<Temporary - Array pointer> ;4 (-3)
<Temp. - Integer form of 1(RA)> ;5 (-2)
⊗;
↑DELAY: AOS INSXR,4(RA) ;INCREMENT OUTPUT PTR.
CAML INSXR,5(RA) ;IS IT TIME TO WRAP AROUND ?
SETZB INSXR,4(RA) ;YES.
MOVE 1,@3(RA) ;GET OUTPUT OF DELAY LINE.
MOVE 0,@1(RA) ;GET DELAY TIME, T.
KIFIX 0,0
ADD INSXR,0 ;MOVE PTR. AROUND TO INPUT END.
CAML INSXR,5(RA) ;PROBABLY HAVE TO WRAP AROUND..
SUB INSXR,5(RA) ;YUP. SUBTRACT LENGTH OF DELAY ARRAY.
MOVE 2,@(RA) ;GET INPUT SAMPLE.
MOVEM 2,@3(RA) ;PLACE IN INPUT OF DELAY LINE.
JRST 6(RA) ;RETURN.
SUBTTL Random Numbers
;; RANDOM NUMBER GENERATORS.
COMMENT ⊗
CALLED WITH:
JSP RA,RANDH
<Scale factor> ;0 (-5)
<Increment> ;1 (-4)
<Temp - Sum> ;2 (-3) Gets new random number
<Temp - Random number> ;3 (-2) upon wraparound
⊗;
↑RANDH: MOVE @1(RA) ;GET INCREMENT.
FADB 2(RA) ;INCREMENT THE 'POINTER'.
CAML [512.0] ;OVER 512 ?
JRST RNDH2 ;YES. GO GET NEW RANDOM NUMBER.
MOVE T,@(RA) ;NO. GET INPUT ...
FMPR T,3(RA) ;... AND MULT. BY CURRENT RANDOM NO.
JRST 4(RA) ;RETURN.
RNDH2: MOVSI (-512.0) ;CAUSE 'POINTER' TO 'WRAP AROUND'.
FADM 2(RA)
PUSHJ P,RAND ;GET NEW RANDOM NO.
MOVEM T,3(RA) ;MAKE IT THE CURRENT NO.
FMPR T,@(RA) ;MULT. BY INPUT.
JRST 4(RA) ;RETURN.
↑IRANDI: ;I-TIME CODE FOR RANDI AND RANDH.
↑IRANDH: PUSHJ P,RAND ;INIT. RANDH.
MOVE T2,(RA) ;GET PTR. TO LAST PARAM..
MOVEM T,-2(T2) ;PUT INITIAL RAND. NO. IN.
JRST 1(RA)
↑RANDI: MOVE T,2(RA) ;GET CURRENT DELTA..
FADRB T,4(RA) ;ADD TO LAST OUTPUT VALUE...
SOSG 3(RA) ;DECREMENT STEP COUNTER ...
JRST RNDI2 ;IT'S 0, SO GET NEW RANDOM NO.
FMPR T,@(RA) ;NO. MULT BY INPUT.
JRST 5(RA) ;RETURN.
RNDI2: PUSHJ P,RAND ;GET NEXT RANDOM NO.
FSBR T,4(RA) ;FORM DELTA (=NEW - OLD)
MOVSI T1,(512.0)
FDVR T1,@1(RA) ;NO. OF STEPS = 512/(FREQ. INPUT)
FDVR T,T1 ;CHANGE PER STEP =DELTA/NO. OF STEPS
MOVEM T,2(RA) ;STORE CHANGE PER STEP.
KIFIX T1,T1
MOVEM T1,3(RA) ;PUT IT AWAY.
JRST RANDI ;NOW GO GENERATE FIRST STEP.
BEND U.G.
IFN 0,< ; JAM 11/12/75 - MAKE THIS THING HONEST!!!
RAND: MOVE T,RNDNO1 ;GENERATE A RANDOM NO.
ADD T,RNDNO2 ;How dare you call this a random number
EXCH T,RNDNO2 ;generator!!!
MOVEM T,RNDNO1
ASH T,-10 ;SMEAR SIGN INTO EXPONENT FIELD..
FSC T,200 ;... AND FLOAT IT IN RANGE -1 TO 1.
POPJ P,
RNDNO1: 756132257563
RNDNO2: 756132257565
>; IFN 0,JAM 11/12/75 - MATCHES IFN 0 ABOVE
; LINEAR CONGRUENTIAL RANDOM NUMBER GENERATOR
RAND: SKIPE T,SEED ; PICK UP LAST NUMBER
JRST RAND1 ; ALREADY INITIALIZED
RUNTIM T, ; NEED NEW SEED, GET IT FROM DATE AND TIME
ROT T,=12 ; SCRAMBLE THESE NUMBERS GOOD
MSTIME T1,
XOR T,T1
ROT T,=12 ; INVERT THE SIGNIFICANCE OF THE BITS
DATE T1,
XOR T,T1
RAND1: IMUL T,[267455123765]
MOVS T,T
MOVEM T,SEED
ASH T,-10 ;SMEAR SIGN INTO EXPONENT FIELD..
FSC T,200 ;... AND FLOAT IT IN RANGE -1 TO 1.
POPJ P,
SEED: 0 ; LAST RANDOM NUMBER GENERATED
SUBTTL FORTRASH Routines and Random Functions
INTERNAL RDNUM,MESS,PNUM,QTTYIN,INFILE,SBFILN,SBDEVN
;SBFILN=FILE NAME FOR PLAY PROG. SBDEVN=DEVICE NAME
EXTERNAL JOBDDT;
FOOPRT: 0
JRST PNUM2
PNUM: 0
; MOVE P,JOBFF ;$%%##$$##
MOVE P,[IOWD LOSTK,OSTK] ;THAT'S BETTER!
PNUM2: JSR SAVE
MOVE A,@(RA)
PUSHJ P,OUTFLT
JSR RESTORE
JRA RA,1(RA)
RDNUM: 0 ;NUMBER READER FOR FOOTRAN ROUTINES.
; MOVE P,JOBFF ;GET TEMP. PDL *****
MOVEM P,RDNUMP#
MOVE P,[IOWD LOSTK,OSTK] ;THAT'S BETTER!
EXCH FL,FLSV1
RDNUM1: TLO FL,SNUMF1+NOSTAR ;INHIBIT PROMPT!
PUSHJ P,SCAN
CAMN A,MINV ;A MINUS SIGN ?
TLOA FL,MINFLG ;YES. SET FLAG AND LOOP BACK.
TLNN A,NUMFLG ;IT IS A NUMBER, ISN'T IT ?
JRST RDNUM1 ;NO. IGNORE IT.
TLZE FL,MINFLG ;YES. HAVE WE SEEN A MINUS LATELY ?
MOVNS C ;YES.
MOVEM C,@(RA) ;PUT VALUE INTO PARAMETER.
TLZ FL,NOSTAR
EXCH FL,FLSV1
MOVE P,RDNUMP
JRA RA,1(RA) ;RETURN TO (UGH ! BLETCH !) FOOTRAN.
MESS: 0 ;MESSAGE PRINTER FOR FOOTRAN ROUTINES.
HRRZ (RA) ;GET LOC. OF MESSAGE.
HRLI 440700
MESS1: ILDB 1,
SKIPN 1
JRA RA,1(RA)
CAIN 1,"/"
JRST [ OUTSTR[ASCIZ/
/]
JRST MESS1]
OUTCHR 1
JRST MESS1
INT: 0 ;INTEGER PART
;Cretinous KI10 does a FORTRAN FIX, not the Entier function!
;So, we get to do the floor function the hard way!
KIFIX 0,@(RA) ;Use KI10 fix instruction in to do hard stuff
FSC 0,233
SKIPGE @(RA) ;Argument negative?
CAMN 0,@(RA) ; And was not already an integer
JRA RA,1(RA) ; No, return FIX(X)
FSBRI 0,(<1.0>) ;Yes, then KIFIX is off by one for
JRA RA,1(RA) ;Entier function
QTTYIN: 0 ;ICK! BLETCH! MORE FORTRASH! SUBROUTINE TO RETURN
; 0 IF NOT INPUTING FROM TTY
MOVSI 0,'TTY' ;-1 IF TTY IS REALLY A III
CAMN 0,DNAM ;-2 IF TTY IS DD
JRST .+3
SETZ 0,
JRA RA,1(RA)
SETOB 0,LINCHR
TTYUUO 6,LINCHR#
SKIPL LINCHR
SOS 0
FSC 0,233
JRA RA,(RA)
STRLEN
ARRLEN: 0 ;Returns length of array
HRRZ 1,(RA)
MOVE 1,-1(1)
FSC 1,233
JRA RA,1(RA)
STRLEN: 0 ;Returns length of string
MOVEM 2,SAVE2#
HRRZ 2,(RA)
HRLI 2,440700
SETZ 1,
ILDB 0,2
JUMPE 0,[ MOVE 2,SAVE2#
FSC 1,233
JRA RA,1(RA) ]
AOJA 1,.-2
;ARRBLT(TO,FROM,COUNT)
ARRBLT:0
HRRZ 0,(RA)
HRL 0,1(RA)
HRRE 1,@2(RA)
ADD 1,(RA)
BLT 0,-1(1)
JRA RA,3(RA)
SUBTTL Extended Commands
;(PRECEDED BY <ALT MODE> OR ⊗)
COMMND:
SETO 1,
TTYUUO 6,1
TLNN 1,420000 ;SKIP IF NOT AT DD OR III
OUTSTR [ASCII /$/]
PUSHJ P,SCANNS ;GET COMMAND.
CAMN A,EXITV ;AN EXIT?
EXIT
CAME A,LISTV
TLNE A,DECLBIT
JRST CMDLST ;A LIST STATEMENT
JUMPL A,[COMND1: OUTSTR [ASCIZ /UNKNOWN COMMAND?? /]
JRST SCHOWN]
MOVE ACCUM
MOVE 1,ACCUM+1
LSHC 6
SETZ B,
COMND2: SKIPN CMDTAB(B)
JRST COMND1
CAME CMDTAB(B)
AOJA B,COMND2
JRST @CMDTA2(B)
CMDTAB: ;TABLE OF EXTENDED COMMANDS
;;; SIXBIT/DDT/
;;; SIXBIT/EDIT/
SIXBIT/EXCISE/
SIXBIT/FREEZE/
;;; SIXBIT/HELP/
;;; SIXBIT/NEWS/
SIXBIT/P/
;;; SIXBIT/PLAY/
;;; SIXBIT/PRINT/
;;; SIXBIT/RESET/
;; SIXBIT/SAVE/
;; SIXBIT/SPACE/
0
CMDTA2:
;;; COMDDT
;;; CMDEDT
EXCISE
FREEZ1
;;; 0
;;; 0
;; CPLX
;; CPLX
CPLAY
;;; CPLAY
;;; CPNT
;;; REST1
;; SAVBUF
;; CSPACE
;;;COMDDT: SKIPN JOBDDT
;;; JRST SCHOWN
;;; PUSH P,[SCHOWN+1]
;;; JRST DDTGO]
;;CPLX: PUSHJ P,CGNUM ;GET FOLLOWING NUMBER, IF ANY.
;; MOVEI T,1 ;NO NUMBER. TAKE AS 1.
CPLAY: PUSHJ P,PLAY↑
JRST SCHOWN
; More Command Routines.
;;;REST1:
;;; SETOM ONCEFG ;THE RESET WILL BE DONE AT GO
;;; MOVE OLDJFF ;RESET JOBFF
;;; MOVEM JOBFF
;;; JRST GO
EXCISE:
MOVE JOBFF
CORE
SYSERR<Can't reduce core!>
COMMENT ⊗ Shouldn't happen. ⊗;
MOVE JOBREL
MOVEM BEGFRE ;UPDATE FREE STORAGE POINTER
JRST SCHOWN
FREEZ1:
SETOM ONCEFG ;TURN ON HELP MESSAGE, ETC.
MOVE A,[XWD BUCTBL,SVAREA]
BLT A,2*SVAREA-BUCTBL-1 ;SAVE SYMBOL TABLE POINTERS
MOVE JOBFF ;SAVE JOBFF
MOVEM OLDJFF
CORE
SYSERR <Can't reduce core!>
COMMENT ⊗ Shouldn't happen. ⊗;
OUTSTR [ASCIZ/FROZEN!/]
EXIT 1,
JRST GO
;;;CPNT: PUSHJ P,SCOMPA ;INIT. THE COMPILER.
; PUSH OSP,[XWD VRBLBT,[XWD VRBLBT,CPNTX#]] ;PUT FAKE VARIABLE IN STACK.
; PUSHJ P,ASTMT1 ;COMPILE RIGHT PART OF AN ASSIGNENT STATEMENT.
; PUSHJ P,INTERP ;EXECUTE THE CODE.
; MOVM A,CPNTX ;GET ITS VALUE.
;;;CPNT2: PUSHJ P,OUTFLT ;PRINT FLOATING
; OUTPUT TTY,0
; POP P,A ;GET THING WHICH TERMINATED EXPR. (LEFT ON STACK BY ASTMT1).
; CAMN A,SEMICV ;A SEMICOLON ?
; JRST SCHOWN ;YES. FORGET IT.
; JRST CHOWN ;NO. LOOK AT IT.
; This handy routine tells you what's in the symbol table
;THE COMMAND FORM
CMDLST: PUSH P,[[PUSHJ P,SCAN ;EAT THE OPTIONAL 'LIST'
CAME A,LISTV
JRST CHOWN
JRST SCHOWN]]
LSTSYM: MOVE B,[XWD -(LSTEND-LSTTAB)-1,LSTTAB-1]
AOBJP B,CPOPJ ;SEARCH FOR TYPE DECLARATION FAILED
CAME A,@(B) ;THIS TYPE?
JRST .-2 ;NO, TRY NEXT
HLRZ C,(B) ;GET RANDOM GOOD BIT
MOVE D,[XWD -BUCKNO-1,BUCTBL-1] ;SEARCH EACH BUCKET
AOBJP D,CPOPJ ;LAST ONE?
MOVE B,(D) ;GET BEGINNING OF BUCKET
LSTLOOP:CAIN B,A-1 ;AT END?
JRST .-3 ;YES
MOVE A,2(B) ;FOR PRNTSYM
TLNE A,(C) ;RIGHT RANDOM GOOD BIT ON?
JRST [ MOVEI A,2(B) ;FOR PRNTSYM
PUSHJ P,PRNTSYM ;YES, PRINT SYMBOL NAME
OUTSTR[ASCIZ/ /]
JRST LSTLO1]
LSTLO1: MOVE B,(B) ;GET NEXT ONE ON LIST
JRST LSTLOOP
LSTTAB: XWD VRBLBT,VARV
XWD ARRYBT,ARRV
XWD INSBIT,INSV
XWD FUNBIT,FUNV
XWD UGBIT,UGV
XWD 777740,LISTV
LSTEND←←.
;ROUTINE CALLABLE FROM DDT
LISTSY: JSR SAVE ;SAVE AC'S
EXCH H,SNCHR ;SAVE SNCHR
OUTSTR[ASCIZ/
FOR:/]
PUSHJ P,SCANNS
PUSHJ P,LSTSYM
EXCH H,SNCHR ;RESTORE SNCHR
JSR RESTORE
POPJ P,
SUBTTL SMPOUT - Sample Output Buffer Routines
;THIS IS THE NEW MAGIC SAMPLE BUFFER ROUTINES, WATCH THEM HANDLE
;THE DISK, THE UDP AND THE DAC, ALL IN ONE PROGRAM!!!
BEGIN SMPOUT
DBLKSZ←←200 ;SIZE OF A DISK BLOCK
;;;UBLKSZ←←=2336
DBFNUM←←=10 ;NUMBER OF BUFFERS (SHOULD BE SOME FACTOR OF 18, PLUS 2)
;BUFFERING
SBDNUM←←=11*=18 ;NUMBER OF BLOCKS IN A SAMPLE FILE (SHOULD BE MULTIPLE
;THE RECORDS/TRACK FOR DISK
SBMNUM←←=11*=18 ;FOR MAG TAPE
SBUNUM←←10 ;NUMBER OF BLOCKS BETWEEN SAVES (MUST BE POWER OF 2)
;;;TOUDP←←1
TODSK←←2
DEVIOS←←2 ;OFFSET TO I/O STATUS WORD IN DDB
IOSYNC←←40 ;ONE BUFFER AT A TIME, PLEASE (SYMBOL: 'IOSYNC` INVENTED)
;;;UDPABS←←100 ;OPEN UDP IN ABSOLUTE MODE
↑PLINIT:SETZM BLKNUM ;CLEAR BLOCK COUNT
SETZM SAVDON ;CLEAR .SAV WRITTEN FLAG
SETZM QUIET# ;SUPPRESS STATS AND FILE INC.
SETZM SBWC ;CLEAR WORD COUNT
SETZM RUFLAG ;CLEAR 'RUN .SAV` FLAG
MOVEI A,1
MOVEM A,SBUSET ;Reset USETO pointer
OUTPUT TTY, ;FLUSH THE TTY BUFFER, WE'RE TTYUUOING AROUND
;HERE
LDB A,SCP ;Check for PLAY <file spec>
CAIN A," "
JRST [ MOVE A,[PUSHJ P,SCNGET]
JRST PNOASK ]
MOVSI A,(<POINT 7,0>) ;Make string pointer to default output
HRR A,OUTFIL ;specification.
MOVEM A,SPCPTR#
MOVE A,[ILDB 1,SPCPTR]
SKIPN @OUTFIL ;Make sure there is something there
PLOOP1: MOVE A,[INCHWL 1] ;CHARACTER STREAM
PNOASK: MOVEM A,PLAYOP#
SETZM BYTSIZ
CAMN A,[INCHWL 1]
OUTSTR [ASCIZ/
Output: /]
PUSH P,[SBDEVC+1]
PUSH P,PLAYOP
PUSH P,[0]
PUSHJ P,RDIOSP
JFCL
PUSHJ P,IGNOLF
SETZ A,
SKIPN SBFILN+1 ;DOES FILE HAVE AN EXTENSION
JRST [ SKIPN SBFILN ;NO, A FILE NAME?
JRST INIDSK ; GO INIT DSK
;;; JRST PLOOP2 ;NO, THAT'S OK, IT'S JUST A DEVICE
TYPSTR [ASCIZ/Please include an extension or ':'
/]
JRST PLINIT]
SKIPN SBFILN
JRST [ TYPSTR [ASCIZ/You need a file name.
/]
JRST PLOOP1]
JRST INIDSK ;***** NEW OCT 9,77
PLINI2: MOVEM F,PLYOPT ;SAVE PLAY OPTION NUMBER
MOVE SIZ,SSIZES(F) ;GET BUFFER SIZE
MOVEM SIZ,LSBUF ;SAVE BUFFER SIZE
PLINLO: MOVE T,BEGFREE ; FIGURE OUT HOW MUCH SPACE WE HAVE
SUB T,JOBFF
SUBI T,4*LOBUFS
CAMGE T,SIZ
COREFULL ;GET SOME CORE WHILE WE CAN
JRST PLINLO ;TRY AGAIN
MOVN T,SIZ
PUSHJ P,GFS ;CALL FREE STORAGE ROUTINE
MOVE THIS,T
MOVEM THIS,SBBOTT;SAVE ADDRESS OF BUFFER
REINIT: MOVE THIS,SBBOTT
HLL THIS,SBPTRS(F) ;GET APPROPRIATE BYTE POINTER
MOVEM THIS,SBPTR ;SET UP BYTE POINTER FOR SAMPLES
KIFIX BITS ; BITS SETS THE BYTESIZE ********
MOVEM BYTSIZ#
KIFIX SAVIT ; SAVIT SETS THE SAVE RECORD NUM.****
MOVEM SAVCNT
SKIPE SIZ,BYTSIZ ;NON-STANDARD BYTE SIZE?
DPB SIZ,[POINT 6,SBPTR,11]
LDB SIZ,[POINT 6,SBPTR,11]
MOVEI THIS,=36
IDIV THIS,SIZ
MOVEM THIS,NBYTES
IMUL THIS,LSBUF
MOVEM THIS,SBCNT
POPJ P,
↑ANSWER:INCHWL
CAIN 12 ;IN CASE THERE WAS A <LF> IN THE TTY BUFFER
JRST ANSWER
CAIE "y" ;EAT LOWER CASE, TOO
CAIN "Y" ;IF "Y" THEN SKIP
AOS (P)
CAIN 12 ;END OF LINE?
POPJ P, ;YES
INCHWL ;NO, GET ANOTHER AND TRY AGAIN
JRST .-3
EXTERNAL JOBJDA
;DIRECTORY ENTRY FORMAT - SHOULD NOT BE CHANGED WITHOUT CHANGING
; CONVERSION ROUTINES AS WELL!!!
FILELOC ←←0; ! First file name;
EXT1LOC ←←1; ! First ext.;
DATELOC ←←2; ! Date written;
PPNLOC ←←3; ! Location of PPN;
FILE2LOC ←←4; ! Last file name;
EXT2LOC ←←5; ! Last ext.;
FOOLOC ←←6; ! Last word count,,Normal word count;
BAZLOC ←←7; ! Maximum sample,,Number of files;
MAXLOC ←←BAZLOC;
MAKBUF: MOVE SBBOTT ;GET ADDRESS OF BUFFER
PUSH P,SBPTR
EXCH JOBFF
OUTBUF SBCHAN,@BUFNUM(F)
EXCH JOBFF
POP P,0
TLZ 0,770000
HLLM 0,SBPTR
; MOVEI 2200 ;SET TO 18 BIT SAMPLES
; HRLM SBPTR
POPJ P, ;NOW, RETURN
ERROR <ERROR IN SETTING UP BUFFER RINGS>
; Initialize DSK or UDP for output;
INIDSK: SKIPN SBFILN
JRST [ OUTSTR [ASCIZ/Illegal file name
/]
JRST PLINIT]
SETZ B,
INIDS3:
INIDS4: SETZM SBDEVC ;SET BUFFERED MODE
MOVSI SBHDR
MOVEM SBDEVC+2
OPEN SBCHAN,SBDEVC
SYSERR<Can't INIT DSK!>
COMMENT ⊗ An unlikely situation. ⊗;
MOVEI F,TODSK ;DSK IS OPTION 2
PUSHJ P,PLINI2 ;CALL THE BUFFER ALLOCATION
PUSHJ P,MAKBUF
PUSHJ P,ENTFIL
; Sound file headers
;As of 29 March 1977, a sound file header looks like...
; WD 0 - 525252525252
; WD 1 - Clock rate
; has code in LH, actual rate in RH
; code=0 for 6.4Kc (or anything else)
; =1 for 12.8Kc, =2 for 25.6Kc, =3 for 51.2Kc
; =5 for 102.4Kc, =6 for 204.8Kc
; WD 2 - pack
; 0 for 12 bit
; 1 for 16 bit (18 bit)
; 2 for 9 bit floating point incremental
; 3 for 36-bit floating point
; N>9 for N bit bytes in ILDB format
; has # samples per word in LH.
; WD 3 - # channels
; 1 for MONO
; 2 for STEREO
; 4 for QUAD
; WD 4 - Maximum amplitude (if known)
; is a floating point number
; is zero if not known
; is maximum magnitude (abs value) of signal
; WD 5 - is exact number of samples.
; WDs 6-77 Reserved for future expansion
; WDs 100-177 Text description of file (in ASCIZ format)
;
↑WRTHDR:
PUSH P,C ; [IRC] GET AN AC.
MOVE C,SBHDR ; [IRC] GET BUFFER ADDRESS
ADDI C,2 ; [IRC] WELL, ALMOST
HRLZI B,(C) ; SET UP A BLT POINTER
HRRI B,1(C)
SETZM (C) ;****** [IRC] CLEAR OUT HEADER
BLT B,177(C)
MOVE T,[525252525252]
MOVEM T,0(C) ; [IRC] STICK IN HEADER
FIXR T,SRATE ;Take and round the sampling rate
;Check for known speed
MOVEI A,NHDRSP-1 ;Search speed table
HDLP1: CAME T,HDRSPT(A)
SOJG A,HDLP1
HRL T,A ;Put actual speed in left half
MOVEM T,1(C) ; [IRC]
;Check for special packing modes
KIFIX T,BITS
SETZ B,
CAIE T,=12
AOJ B,
MOVEI A,3
SUB A,B ;PUT NUM SMPLS/WD IN LFT. HALF (3 OR 2 ONLY.)
HRL B,A
MOVEM B,2(C) ;PUTS 0 FOR 12, 1 FOR 18 BIT PACKING ONLY.
KIFIX T,NCHNS ;Output number of channels
MOVEM T,3(C) ; [IRC]
IMUL T,TIME ;NCHNS*TIME=TOTAL SMPLS
MOVEM T,5(C) ;Gives total sample count. (6TH WD)
FLTR T,MAXSMP ;Put out max. sample we know about(flting pt.)
MOVEM T,4(C) ; [IRC] (5TH WD)
IFN 0,< SETZ T, ; [IRC]
MOVEI B,100-5
HDUDLP: PUSHJ P,STUFF ;Output undefined part of header
SOJG B,HDUDLP
MOVEI T,=7
DPB T,[POINT 6,SBPTR,11] ;Set packing bytesize for description
MOVEI T,=5
IMULM T,SBCNT
;Output descriptive part of header
SETZ A, ;THESE 2 REPLACE GETPPN A,
DSKPPN A, ; X X X X
;;; GETPPN A, ;Output PPN
PUSH P,A
PUSH P,[=12]
PUSH P,[PUSHJ P,STUFF]
PUSHJ P,WROCT↑
;Output date
MOVEI T," "
PUSHJ P,STUFF
DATE A, ;Decode the date
IDIVI A,=31
ADDI B,1
PUSHJ P,[
HDNUM: PUSH P,B
PUSH P,[=10]
PUSH P,[PUSHJ P,STUFF]
PUSHJ P,WRINT↑
POPJ P,]
IDIVI A,=12
ADD B,[POINT 7,MONNAM]
HDMON1: ILDB T,B
JUMPE T,HDMON2
PUSHJ P,STUFF
JRST HDMON1
HDMON2: MOVNI B,64
SUB B,A
PUSHJ P,HDNUM
;Output input file name
MOVEI T," "
PUSHJ P,STUFF
PUSH P,[DNAM]
PUSH P,[PUSHJ P,STUFF]
PUSHJ P,WRIOSP↑
SETZ T,
MOVEI A,1
HDFINL: PUSHJ P,STUFF ;Repeat until end of buffer
CAME A,SBCNT
JRST HDFINL
POP P,A
HLLM A,SBPTR ;Put back old byte pointer
SOS SBCNT ;I don't know why this is here, but it helps
> ; END IFN 0 ABOVE [IRC]
HRLZI A,-200 ; [IRC] MAKE UP A IOWD
HRRI A,-1(C)
GETSTS SBCHAN,B ; [IRC] GET OUR STATUS
PUSH P,B ; SAVE IT
SETZ B,
SETSTS SBCHAN,17 ; [IRC] CHANGE TO DUMP MODE
OUTPUT SBCHAN,A ; [IRC]
POP P,B ; [IRC] GET BACK OLD STATUS
SETSTS SBCHAN,(B)
POP P,C ; [IRC]
POPJ P, ;Next output will put out header
;IFN 0,< ; [IRC]
;***STUFF: SOSLE SBCNT ;Dec. byte or word count
;*** JRST STUFF2
;*** WARN (Header bug???)
;;; PUSHJ P,@OUTTAB(F) ;FLUSH FULL BUFFER.
;*** OUT SBCHANS,
;*** SKIPA
;*** WARN <Output error?>
COMMENT ⊗ Error detected while writing out sample buffer ⊗;
;***STUFF2: IDPB 1,SBPTR ; OK to stuff byte into buffer
;*** POPJ P,
;MONNAM: ASCIZ/-Jan/
; ASCIZ/-Feb/
; ASCIZ/-Mar/
; ASCIZ/-Apr/
; ASCIZ/-May/
; ASCIZ/-Jun/
; ASCIZ/-Jul/
; ASCIZ/-Aug/
; ASCIZ/-Sep/
; ASCIZ/-Oct/
; ASCIZ/-Nov/
; ASCIZ/-Dec/
;> ; END IFN 0 ABOVE [IRC]
;Header speed table
HDRSPT: =6400
=12800
=25600
=51200
=102400
NHDRSP==.-HDRSPT
; Routines to Make File Names, and Keep the System Happy
;OUTPUT IN DUMP MODE
DMPOUT: MOVN A,SSIZES(F) ;MAKE AN IOWD
HRL A,SBBOTT ;GET ADDRESS OF BUFFER
SUB A,[XWD 1,0]
MOVSM A,SBIOWD
OUT SBCHAN,SBIOWD ;DO DUMP MODE OUTPUT
POPJ P,
DMPOU2: WARN <Output error?>
COMMENT ⊗ Error detected while writing out sample buffer ⊗;
POPJ P,
BUFOUT: AOS SBUSET ;Update USETO pointer
OUT SBCHAN,
POPJ P,
WARN <Output error?>
COMMENT ⊗ Error detected while writing out sample buffer ⊗;
POPJ P,
FINFIL: JFCL ;BUFFERED I/O?
CAIN F,TODSK
PUSHJ P,BUFOUT ;YES
CLOSE SBCHAN, ;WRITE END OF FILE
MOVE A,BLKNUM
JSA RA,SAVER ;SAVE A DUMP FILE
SKIPN QUIET
PUSHJ P,STATS ;PRINT STATISTICS
SKIPN QUIET
TYPSTR [ASCIZ/ /]
PUSH P,SBHDR ;SAVE HEADER FOR BUFFER RING (OPEN CLOBBERS THESE!)
PUSH P,SBPTR ;SAVE BYTE POINTER
OPEN SBCHAN,SBDEVC
ERROR <Can't re-INIT output device.>
COMMENT ⊗ Someone else it probably using it. ⊗;
POP P,SBPTR ;RESTORE BYTE POINTER
POP P,SBHDR
MOVE A,SBHDR ;Go thru buffer ring clearing use bits
PUSH P,B ;Save a register
MOVSI B,400000
CLRRNG: ANDCAM B,(A) ;Clear use bit
HRR A,(A) ;Pickup next buffer
CAME A,SBHDR ;Done yet?
JRST CLRRNG
POP P,B ;Restore register
AOS BLKNUM
HLLZ 1,SBFILN+1 ;INCREMENT EXTENSION
JRST[ SETZM SBFILN+3 ;;;MOVE 0,SBFILN+3 ;Save PPN over LOOKUP
RSBLOK: LOOKUP SBCHAN,SBFILN ;LOOKUP file to extend it
JRST[ ERROR <Can't find file just written to extend it>
COMMENT ⊗ The music program saves its computation in a way that could be
continued from. Part of this involves closing the output file and then
opening again to extend it. However, upon trying to open it, the file
could not be found!! Run your .SAV file after figuring out where the
file disappeared to ⊗;
JRST RSBLOK]
RSBENT: SETZM SBFILN+3
ENTER SBCHAN,SBFILN
JRST[ WARN <Someone is reading the sound file you are trying to write>
JRST RSBENT]
USETO SBCHAN,@SBUSET ;Move to remembered end of file.
JRST FINFI2] ;Finish setting up for more output.
ENTFIL: SETZM SBFILN+3
ENTER SBCHAN,SBFILN ;ENTER THE FILE NAME
ERROR <Can't OPEN output file>
COMMENT ⊗ Usually this means the file is protected or already being
written. ⊗;
FINFI2:
MOVEI A,SBCHAN ;Display progress of output file with WHO line
SHOWIT A,
OUT SBCHAN,
JRST .+2
ERROR <Can't setup buffers for output>
COMMENT ⊗ This error is probably due to some change to I/O in system. ⊗;
SKIPG A,SAVCNT ;Skip if save count specified
MOVE A,SBBLKS(F) ;SET NUMBER OF 128 WORD BLOCKS PER FILE
MOVEM A,SBBCNT
SETZM SBWC
POPJ P,
; Sample Output Routines For Each Device
DSKOUT:
SKIPE SAVCNT ;Ignore NOMAX if saving
SOSLE SBBCNT ;DON'T SAVE EVERY TIME THRU
JRST BUFOUT ; Output buffer and return
PUSHJ P,FINFIL ;Write out file and re-open to extend
POPJ P, ;Return
DSKFIN: PUSHJ P,FILLBF ;FILL REMAINDER OF BUFFER WITH 4000'S
;AND PRINT WORD COUNT, ETC.
CLOSE SBCHAN, ;SAVE, SET UP FILES, ETC.
DSKFI2: MOVE THIS,SBBOTT ;GET LOWER OF TWO OUTPUT
;DECREMENT TO POINT TO BEGINNING OF
;FREE STORAGE BLOCK TO BE RELEASED
;;; JRST SBFIN2 ;WRITE OUT LAST BLOCK AND CLOSE FILE
; Finished Doing Output, Close and Release Space
SBFIN2: RELEAS SBCHAN,
MOVE SSIZES(F)
ADDM BEGFREE
POPJ P, ;RETURN
FILLBF:
CAIN F,TODSK ;To disk?
USETO SBCHAN,1 ;Back to beginning of file
OUT SBCHAN, ;Setup buffers for WRTHDR
PUSHJ P,WRTHDR ;Write out header
FILLB3:
STATS: TYPSTR [ASCIZ/
/]
JRST [ PUSH P,[SBFILN]
PUSHJ P,PRTFLN
JRST STATS1]
STATS1: TYPSTR [ASCIZ/ Max. sample = /]
MOVE A,MAXSMP ;PRINT MAXIMUM SAMPLE
PUSHJ P,DECPNT
KIFIX A,BITS
TYPSTR [ASCIZ/ Bits = /]
PUSHJ P,DECPNT
TYPSTR [ASCIZ/ Time = /]
MOVE A,TIME
CAME H,[XWD 200000,0]
SUB A,H
FSC A,233
FDVR A,SRATE
PUSHJ P,OUTFLT ;PRINT REAL TIME
TYPSTR[ASCIZ/ /]
POPJ P,
SUBTTL Sample Buffer Tables, etc.
SBPTRS: POINT 12,0 ;BYTE POINTER
POINT 18,0
POINT 18,0
POINT 18,0
BYTWRD: 3 ;BYTES/WORD
2
2
2
SSIZES: 0 ;OPTIMAL BUFFER SIZE
0
;;; UBLKSZ
DBFNUM*(DBLKSZ+3)+1 ;EXTRA WORD TO PREVENT EXTRA K OF
3*(DBLKSZ+3)+1 ;CORE TO BE ALLOCATED
SBBLKS: 0
SBUNUM
SBDNUM
SBMNUM
BUFNUM: 0 ;(ENTRY NOT USED);TABLE OF RECORD SIZES
0 ;(ENTRY NOT USED)
DBFNUM ;DISK RECORD SIZE
↑OUTTAB:0 ;TABLE OF OUTPUT ROUTINES
0
;;; UDPOUT
DSKOUT
↑FINTAB:0 ;TABLE OF ROUTINES TO CALL AT END
0
;;; UDPFIN
DSKFIN
↑PLYOPT:0 ;USED TO DETERMINE WHICH ROUTINE TO CALL TO
;DO OUTPUT, ETC.
SBBCNT: 0 ;IF OUTPUT IS TO DISK, THE NUMBER OF BLOCKS
;REMAINING TO BE WRITTTEN ON THIS FILE
↑MTSYSA:[-1] ;ADDRESS OF WORD USED TO DETECT 'INTERRUPT' TO COMPUTATION
;OF SAMPLE
↑SBDEVC: 0 ;MODE
↑SBDEVN: 0 ;DEVICE NAME
0 ;POINTER TO BUFFER HEADER
↑SBFILN:BLOCK 4 ;FILE NAME
↑SBHDR: 0 ;BUFFER HEADER
↑SBPTR: 0 ;BYTE POINTER
↑SBCNT: 0 ;NUMBER OF BYTES LEFT IN BUFFER
SBWC: 0
↑NBYTES: 0 ;NUMBER OF BYTES/WORD
SBUSET: 1 ;USETO pointer
↑SAVCNT: 0 ;Flag and/or inverval (in buffers) between saves
↑SBIOWD:0 ;IOWD FOR SAMPLE BUFFER
↑BLKNUM:0 ;NUMBER OF THE BLOCK (FILE) BEING WRITTEN ON
;THE UDP(DISK)
SBBOTT: 0 ;POINTER TO BEGINNING OF BUFFER BEING FILLED
↑PZEROS:BLOCK 4
BEND SMPOUT
SUBTTL SAVER
BEGIN SAVER
; (INSERTED 11/3/69)
; TO DUMP CORE IMAGE
; CREATE A FILE OF THE CURRENT CORE IMAGE.
; PICK UP THE USER'S INPUT FILE NAME STORED
; IN DLK AND CREATE A FILE CALLED:
; "NAME.SAV"
; WHERE NAME IS THE INPUT FILE NAME.
;
; THE SWAP UU0 WILL BE USED WHICH CLOSES ALL
; ACTIVE DEVICES.
INTERNAL SAVER
↑SAVER: 0
MOVEM 17,ACS+17 ;SAVE REGISTERS
MOVEI 17,ACS
BLT 17,ACS+16
MOVE 0,SCP ;BASE OF INPUT BUFFER
HRRZ T,IBUF ;CURRENT BUFFER
SUBI 0,-BUF1-1(T) ;DIFFERENCE
MOVEM 0,PLIST+LPLIST-10
SKIPN T,DLK ;INPUT FILE NAME
MOVSI T,'SAV' ;DEFAULT FILE NAME
MOVEM T,SWPTBL+1
MOVE T,JOBREL ;GET LENGTH OF CORE IMAGE (SYSTEM THINKS
;THAT PART OF THE CORE IMAGE IS BUFFERS
;AND DOES NOT SAVE ALL OF IT.)
AOJ T, ;ADD 1 TO GET CORE SIZE
ASH T,-=10 ;DIVIDE BY 1024
HRLM T,SWPTBL+3 ;SET SAVE SIZE IN 1K BLOCKS
SETOM SAVDON ;INDICATE SAVE WAS DONE
MOVSI T,SWPTBL ;ADDR OF 5 WORD BLOCK IN LEFT PART OF T
SWAP T,
SETZM RUFLAG ;CLEAR FLAG INDICATING RESTART
JRST RETR+1
RETR: SETOM RUFLAG ;SET FLAG INDICATING RESTART
MOVE P,[XWD -10,PLIST+LPLIST-10] ;PICK UP ACCUM P
MOVEI FL,RESTART ;RESTORE RESTART FLAG
SOS RECCT ;BACK UP TO PREVIOUS INPUT RECORD.
PUSHJ P,SETUP ;JUMP TO RESTORE FILES
POP P,SCP
MOVEI GO ;FIX UP STARTING ADDRESS
HRRM JOBSA
MOVE [SIXBIT/MUSIC/]
SETNAM
MOVSI 17,ACS ;RESTORE REGISTERS
BLT 17,17
JRA 16,(16)
↑RUFLAG: 0 ;FLAG INDICATING PROGRAM STARTED FROM A .SAV FILE
↑SAVDON: 0 ;FLAG INDICATING PROGRAM HAD BEEN SAVED AT LEAST ONCE
ACS: BLOCK 20 ;REGISTER SAVE AREA
↑SWPTBL:SIXBIT /DSK/ ;DEVICE FOR SWAP
SIXBIT /SAV/ ;FOR FILENAME
SIXBIT /SAV !/ ;FILENAME.SAV (SAVE SEGMENT ALSO)
XWD 0,RETR ;CORE SIZE (0=USE WHAT YOU NEED)
0 ;END OF LIST
BEND SAVER
SUBTTL Storage Management
;GET BLOCK OF FREE STORAGE
;CALL WITH -SIZE IN T, RETURNS ADDRESS IN T, CLOBBERS 0
GFS: PUSH P,A ;SAVE A
HRRO A,T ;TO BE SURE (AND TO NOT MUNG T YET)
ADD A,BEGFREE ;DECREMENT BEGINNING OF FREE STORAGE. *****
TLNE A,777777
PUSHJ P,DRYROT ;BUG TRAP
CAMG A,JOBFF ;ROOM LEFT? ****
COREFULL ;NO, LET'S SEE IF WE CAN GET SOME
JRST GFS+1 ;WE GOT MORE SPACE! TRY AGAIN
MOVEM A,BEGFREE ;RETURN ADDRESS IN T *****
EXCH A,T
POP P,A ;RESTORE A
POPJ P,
;GET BLOCK OF PERMANENT STORAGE
;CALL WITH SIZE IN T, RETURNS ADDRESS IN T
GPS: HRRZ T,T ;JUST IN CASE...
ADD T,JOBFF ;ADD TO TOP OF PERMANENT STORAGE
CAML T,BEGFREE ;*****
COREFULL ;NO, LET'S SEE IF WE CAN GET SOME
JRST GPS+2 ;WE GOT MORE SPACE! TRY AGAIN
HRLM T,JOBSA
EXCH T,JOBFF ;RETURN ADDRESS IN T *****
POPJ P,
.CORFL: PUSH P,0 ;SAVE AC0
MOVE JOBREL ;IS FREE STORAGE IN USE?
CAME BEGFREE
JRST [ ;YES, BARF!
SETOM GETMORE ;SET FLAG TO GET CORE UPON RESTART
MOVE -1(P)
MOVEM LSTFUL ;SAVE ADDRESS OF CALLER FOR DEBUGGING
POP P,0
ERROR <Storage full!>
POPJ P,]
SKIPN NO.MSG ;Don't print if in quiet mode
OUTSTR[ASCIZ/
Getting more core.../] ;NO, LET'S GET SOME MORE
MOVE JOBREL
ADDI 2000
CORE
JRST [ ERROR<Can't expand core!>
COMMENT ⊗ Could get enough core. You lose. ⊗;
JRST .CORFL]
MOVE JOBREL
MOVEM BEGFREE
SKIPN NO.MSG
OUTSTR[ASCIZ/
/]
POP P,0
AOS (P)
POPJ P,
;CALLED FROM INIDAC
SETCOR: CORE
JRST [ ERROR<Can't expand core>
HALT $.]
MOVE JOBREL
MOVEM BEGFREE
POPJ P,
;SIXOUT and PRTFLN
SIXOUT: HRLI 440600 ;MAKE BYTE POINTER
LOOPTS: SOJL T1,OTTYRT ;IF DONE, FLUSH TTY BUFFER
ILDB T,0
JUMPE T,OTTYRT
SIXOU3: ADDI T,40
TYPCHR T
JRST LOOPTS
;PRINT FILE NAME
PRTFLN: MOVEI T1,6
MOVE -1(P) ;GET ADDRESS OF FILE NAME
PUSHJ P,SIXOUT
ADDI 1 ;LOOK AT FILE NAME
HLRZ T1,@0 ;GET EXTENSION
JUMPE T1,PRTFL1 ;DON'T PRINT NULL EXTENSION
TYPCHR ["."]
MOVEI T1,3
PUSHJ P,SIXOUT
PRTFL1: TYPCHR ["["]
MOVE -1(P)
ADDI 3
SKIPN @0
JRST [ SETZ T1,
DSKPPN T1,
MOVEM T1,@0
JRST PRTFL2]
PRTFL2:
HRLI 440600 ;MAKE BYTE POINTER
PUSHJ P,[PRTFL3: MOVEI T1,3
ILDB T,0
SOJL T1,OTTYRT ;IF DONE, FLUSH TTY BUFFER
JUMPE T,PRTFL3+1
JRST SIXOU3]
TYPCHR [","]
HRLI 220600 ;BYTE POINTER TO MIDDLE OF PPN
PUSHJ P,PRTFL3
TYPCHR ["]"]
SUB P,[XWD 2,2]
JRST @2(P)
TXTOUT: 0
TYPSTR @0
JRST @TXTOUT
;PRINT SYMBOL TABLE ENTRY IN ENTITY IN A
PRNTSYM:HRRZI @A ;GET SYMBOL
ADD [440577777777] ;MAKE A 6 BIT POINTER
ILDB T1, ;GET LENGTH OF SYMBOL
SUBI T1,5 ;HOW MANY IN SECOND PART
PUSH P,T1 ;SAVE FOR LATER
MOVEI T1,5 ;CHARACTER COUNT
PUSHJ P,PRNTS2 ;SIXBIT OUTPUT ROUTINE
POP P,T1 ;RECOVER CHARACTER COUNT
ADDI 0,1 ;SKIP GOODBITS WORD
JUMPLE T1,OTTYRT;DON'T BOTHER IF COUNT<1
HRLI 000600 ;ANOTHER POINTER
PUSHJ P,PRNTS2
OTTYRT: OUTPUT TTY, ;FLUSH TTY BUFFER
POPJ P,
PRNTS2: SOJL T1,CPOPJ
ILDB T,0
JUMPE T,CPOPJ
ADDI T,40
CAIN T,"." ;MAP '.` INTO '_`
MOVEI T,"_"
TYPCHR T
JRST PRNTS2
;PRINT DECLARED MESSAGE
; PUSHJ P,DCLMSG
; [ASCIZ/TYPE OF DECLARATION/]
DCLMSG: SKIPE NO.MSG
JRST DCLRET
MOVE BLEVEL ;INDENT ACCORDING TO NUMBER OF BLOCKS DEEP
SOJL 0,[MOVE @(P) ;GET STRING
TYPSTR @0 ;PRINT IT FOLLOWED BY
PUSHJ P,PRNTSYM ;IDENTIFIER
TYPSTR [ASCIZ/
/] ;AND A CRLF
DCLRET: AOS (P)
POPJ P,]
TYPCHR [" "] ;TWO SPACES PER LEVEL
TYPCHR [" "]
JRST DCLMSG+1
;RDBUF - READ A BUFFER
RDBUF: MOVSI A,'TTY'
CAME A,DNAM ;IS INPUT DEVICE A TTY ?
TLO FL,NOSTAR ;NO. SUPRESS THE *.
TLZN FL,NOSTAR ;PRINT IF NOSTAR NOT ON.
OUTSTR [ASCIZ/
>/] ;YES. TYPE CR LF *.
USETI DT,@RECCT ;POSITION INPUT FILE TO RIGHT RECORD.
AOS RECCT ;ADD 1 TO RECORD CTR
SETOM NOISCP# ;Set flag saying ISCP is invalid
IN DT,0 ;READ NEW INPUT BUFFER.
JRST RDBUF2 ;OK, SET IT UP
STATZ DT,20000 ;ERROR, END OF FILE SEEN ?
JRST SETUP ;YES.
WARN <INPUT ERROR>
RDBUF2: MOVEI 4 ;MAKE SURE 0 WORD TERMINATBES IT.
ADD ICCNT ;CHAR. COUNT +4/5 IS WORD COUNT.
MOVEI A,5 ;BECAUSE WE DON'T WANT TO LOSE B.
IDIVM A ;SEE? NO RANDOM REMAINDER !!
ADD A,SCP ;ADD BASE ADDRESS.
IBP A ;BAGBITING SYSTEM.
SETZM (A) ;ZERO IT.
MOVE SCP
MOVEM ISCP# ;SAVE FOR ERROR PRINTOUT.
SETZM NOISCP ;Clear flag saying ISCP is invalid
POPJ P,
SUBTTL Numeric Output Routines
BEGIN NUMOUT
;OUTPUT IN OCTAL
↑OUTOCT: EXCH A,(P) ;SAVE A, GET RET. ADR.
EXCH A,-1(P) ;SAVE RET. ADR., GET ARG.
PUSH P,B ;SAVE B
SETZ B,
PUSHJ P,OUTOC2
OUTPUT TTY, ;FLUSH TTY BUFFER
POP P,B
POP P,A
POPJ P,
OUTOC2:
; IDIVI A,8 ;PRINT OCTAL NUMBER FROM A.
LSHC A,-3
ROT B,3
HRLM B,(P) ;SAVE LOW ORDER DIGIT.
SKIPE A ;DONE ?
PUSHJ P,OUTOC2 ;NO. RECUR FOR REST OF DIGITS.
HLRZ B,(P) ;YES. GET HIGH ORDER DIGIT.
ADDI B,"0" ;CONVERT TO ASCII.
TYPCHR B ;OUTPUT DIGIT
POPJ P,
;CALL WITH NUMBER TO BE PRINTED IN A
;CLOBBERS A-B
↑DECPNT: PUSH P,C ;SAVE C
JUMPGE A,.+4 ;NEGATIVE
MOVNS A ;YES
MOVEI B,"-" ;OUTPUT A "-"
PUSHJ P,TTYCHR
PUSH P,[DECRET];SET UP RETURN
MOVNI C,1 ;SET FAKE DECIMAL POINT
JRST FLTOU3 ;JUMP INTO FLOATING CHARACTER
DECRET: POP P,C
MOVEI B,40
PUSHJ P,TTYCHR
JRST OTTYRT ;OUTPUT TTY BUFFER AND RETURN
↑OUTFLT: PUSH P,C ;SAVE C
JUMPE A,DECPNT+1;TEST FOR ZERO
MOVEI C,7 ;INIT. EXPONENT
JUMPGE A,.+4 ;NEGATIVE NUMBER?
MOVNS A ;NEGATE NUMBER
MOVEI B,"-" ;OUTPUT A "-"
PUSHJ P,TTYCHR
TLNN A,377000 ;IS IT FLOATING?
JRST DECPNT+1 ;NO! USE DECPNT
CAML A,[999999.5] ;NORMALIZE
JRST .+3
FMPR A,[10.0]
SOJA C,.-3
CAMGE A,[9999999.5]
JRST .+3
FDVR A,[10.0]
AOJA C,.-3
CAIG C,7 ;WILL IT FIT IN FIXED POINT?
JUMPGE C,FLTOU2 ;IF DEC. EXP. BETWEEN -1 AND 5, YES
SUBI C,1 ;TURN INTO ACTUAL EXP.
PUSH P,C ;SAVE EXPONENT
MOVEI C,1
PUSHJ P,FLTOU6 ;CALL SELF TO OUTPUT MANITISSA
MOVEI B,"E" ;OUTPUT "E" (FOR EXPONENT!)
PUSHJ P, TTYCHR
POP P,A ;GET REAL C
JRST DECPNT+1 ;CALL INTEGER OUTPUT TO RETURN IT
FLTOU2: JUMPN C,.+3 ;DEC. EXP =-1
PUSHJ P,FLTOU5 ;PRINT "0."
PUSHJ P,FLTOU4
PUSHJ P, FLTOU6 ;OUTPUT MANTISSA
SOJL C,DECRET ;IF POSITIVE, PRINT TRAILING ZEROS
PUSHJ P,FLTOU5
JRST .-2
FLTOU6:
FIXR A,A ;FIX THE MANTISSA
IDIVI A,=10
JUMPE A,FLTOU3+1;IN CASE OF POWERS OF 2
JUMPE B,.-2 ;IGNORE TRAILING ZEROS
JRST .+2 ;SKIP THE DIVIDE
FLTOU3: IDIVI A,12 ;PRINT DECIMAL INTEGER FROM A.
HRLM B,(P) ;SAVE LOW ORDER DIGIT.
SKIPE A ;DONE ?
PUSHJ P,FLTOU3 ;NO. RECUR FOR REST OF DIGITS.
HLRZ B,(P) ;YES. GET HIGH ORDER DIGIT.
ADDI B,"0" ;CONVERT TO ASCII.
SOJN C,TTYCHR ;DECIMAL POINT?
PUSHJ P,TTYCHR ;OUTPUT DIGIT
FLTOU4: MOVEI B,"." ;AND "."
JRST TTYCHR
FLTOU5: MOVEI B,"0" ;PRINT A ZERO
TTYCHR: TYPCHR B
POPJ P,
BEND NUMOUT
; Read number from TTY
GETNUM: PUSH P,0 ;SAVE 0
SETZ 1,
INCHWL
CAIN 15
JRST [ INCHWL ;EAT THE LINE FEED
POP P,0 ;RESTORE 0
POPJ P,];RETURN
SUBI "0"
IMULI 1,=10
ADD 1,0
CAIG =9
JUMPGE GETNUM+2
OUTSTR [ASCIZ/ILLEGAL CHARACTER IN NUMBER
/]
JRST GETNUM+1
;*****************************************************************
COMMENT ⊗ Character string conversion package
This package is a collection of frequently used conversion
subroutines, such as convert integer to character stream and convert
character stream to sixbit. The character stream source or
destination are defined by a PDP-10 instruction, such as
PUSHJ P,GETCHR. All character stream destinations are expected to
return a character in accumulator 1 and all character stream
destination are expected to recieve its character in accumulator 1.
Subroutines which return arguments always return their arguments in
accumulator 1 and if a break character is to be return, it will be
in accumulator 0. Character streams should not modify any other
accumulators. These subroutines are:
RDINT(Integer BASE; Character_source OPCODE);
Convert character stream into integer, in specified base.
WRINT(Integer N, BASE; Character_destination OPCODE);
Convert integer into character stream, in specified base.
RDSIX(Integer SIXBIT; Character_source OPCODE, Breaktable BRKTAB);
Convert sixbit word into character stream.
WRSIX(Integer SIXBIT; Character_destination OPCODE);
Convert sixbit word into character stream.
RDFLO(Operation OPCODE);
Convert character stream into real, in specified base. (UNIMPLIMENTED)
WREFLO(Real N,CHARACTER_COUNT,CONTROL_WORD; Character_destination
OPCODE);
Convert floating point number into character stream of specified
format. CONTROL_WORD is of form. (See FORTRAN for details on this
format).
XWD <characters to left of decimal point>,<width of field>
RDFILN(Array FILBLK; Character_source OPCODE; Sixbit
DEFAULT_EXTENSION)
Convert a character string into system file name structure.
WRFILN(Array FILBLK; Character_destination OPCODE)
Convert system file name structure into a character string.
WRASCZ(Ascizstring S; Character_destination OPCODE)
A break table is the standard system format four word table
representing which characters are break characters. See UUO Manual
for details. Briefly,
Word 0 contains bits for <null> thru #,
Word 1 contains bits for $ thru G,
Word 2 contains bits for H thru k
Word 3 contains bits for l thru <bs>
Note: LIBRARY.TMP should be a copy of either HEADER.FAI or EXPHD.FAI
⊗;
;;ENTRY RDIOSP ↔ TITLE RDIOSP ↔EXTERNAL RDSIX
; Read a device name and file name into DEVBLK, returning terminator
; in AC 0 and AC 1. Default extension is used if none is given.
; Skip return if successful. If no device or file is given, do not
; alter DEVBLK and non-skip return
;DEVBLK: SIXBIT/DEVNAM/
; XWD OUTPTR,INPTR
; SIXBIT/FILNAM/
; SIXBIT/EXT/
; 0
; SIXBIT/PRJPRG/
RDIOSP: PUSH 17,2
MOVE 2,-4(17)
MOVSI 1,446353 ;DSKM ; FOR IRCAM*******************
MOVEM 1,(2)
PUSHJ 17,RDIOSP+50 ;Read SIXBIT
JUMPE 1,RET
CAIE 0,":"
JRST NODEV
MOVEM 1,(2) ;Set device name
PUSHJ 17,RDIOSP+50
NODEV: MOVEM 1,2(2)
HLLZ 1,-2(17) ;Fetch default extension
MOVEM 1,3(2)
SETZ 1,
CALLI 1,24
MOVEM 1,5(2)
CAIE 0,"." ;Extension coming?
JRST NOTEXT
PUSHJ 17,RDIOSP+50 ;Yes, read it
HLLZM 1,3(2)
NOTEXT: CAIE 0,"[" ;PPN coming?
JRST SKRET ;No, return
PUSH 17,RDIOSP+60 ;Read project
PUSH 17,-4(17)
PUSHJ 17,RDINT ;(Stanford likes it PPN's right justified)
HRLM 1,5(2)
CAIE 0,","
JRST NOTCOM ;Assume he wants same programmer area
PUSH 17,RDIOSP+60 ;Read project
PUSH 17,-4(17)
PUSHJ 17,RDINT ;(Stanford likes it PPN's right justified)
HRRM 1,5(2)
NOTCOM: CAIE 0,"]" ;Don't worry if no ']'
JRST RDIOSP+44
XCT -3(17)
MOVE 0,1
;Skip return
SKRET: AOS -1(17)
;Non-skip return
RET: MOVE 1,0
POP 17,2
JRST POP3J.
PUSH 17,-4(17)
PUSH 17,RDIOSP+61
PUSHJ 17,RDSIX
POPJ 17,0
-11 ;;.PLEVEL←←.PLEVEL+2 ;(Set stack level for subr)
;Read sixbit with appropriate break characters
RDFIL1: FDVRB 16,37600 ;;CALL(RDSIX,OPCODE,[FILBRK])
374000 ;;POP0J
7,,600000
10
RDIOSP+54
POP1J.: SUB 17,POP4J.+2
JRST @2(17)
POP2J.: SUB 17,POP4J.+3
JRST @3(17)
POP3J.: SUB 17,POP4J.+4
JRST @4(17)
POP4J.: SUB 17,POP4J.+5
JRST @5(17)
2,,2
3,,3
4,,4
5,,5
;;ENTRY WRIOSP ↔ TITLE WRIOSP ↔EXTERNAL WRSIX
;;.INSERT LIBRARY.TMP
;;NSUBR WRIOSP,DEVBLK,OPCODE
;; ACCUMULATORS{2,P2}
WRIOSP: PUSH 17,2
EXCH 3,-3(17)
MOVSI 2,440603
LOOP1: ILDB 1,2
JUMPE 1,CONT1
ADDI 1,40
XCT -2(17)
CONT1: CAMN 2,WRIOSP+43
JRST WRIA
CAMN 2,WRIOSP+44
JRST WRIB
WRIC: CAMN 2,WRIOSP+45
JRST LOOP1
EXTDON: SKIPN 5(3)
JRST PPNDON
MOVEI 1,"["
XCT -2(17)
HLRZ 5(3)
PUSH 17,0
PUSH 17,WRIOSP+42
PUSH 17,-4(17)
PUSHJ 17,WRINT
MOVEI 1,54
XCT -2(17)
HRRZ 5(3)
PUSH 17,0
PUSH 17,WRIOSP+42
PUSH 17,-4(17)
PUSHJ 17,WRINT
MOVEI 1,135
XCT -2(17)
PPNDON: EXCH 3,-3(17)
POP 17,2
JRST POP2J.
10
603,,0
603,,2
IMUL 14,3(3)
WRIB: HLLZ 1,3(3)
JUMPN 1,.+2
JRST EXTDON
MOVEI 1,56
XCT -2(17)
JRST WRIC
WRIA: ADDI 2,1
MOVEI 1,72
XCT -2(17)
JRST LOOP1
;;ENTRY RDINT ↔ TITLE RDINT
;;.INSERT LIBRARY.TMP
;Subroutines RDINT,WRINT
;;NSUBR RDINT,BASE,-2(17)
RDINT: SETZ 0,
LOOP: XCT -1(17)
CAIL 1,"0"
CAILE 1,"9"
JRST RDI
IMUL -2(17)
ADDI 0,-60(1)
JRST LOOP
RDI: EXCH 1
JRST POP2J.
;;ENTRY WRINT ↔ TITLE WRINT
;;.INSERT LIBRARY.TMP
;;NSUBR WRINT,INTEGER,BASE,-2(17)
; Convert integer into character stream, in specified base.
WRINT: MOVE 1,-3(17) ;FETCH ARG AND MOVE RET. ADR.
POP 17,-3(17)
POP 17,WRINT+26
POP 17,WRINT+25
PUSH 17,2
PUSH 17,WRINT+27
L1: JUMPGE 1,L2 ;TEST FOR NEGATIVE NUMBER.
MOVM 2,1 ;PRINT MINUS SIGN.
MOVEI 1,"-"
XCT WRINT+26
MOVE 1,2
L2: IDIV 1,WRINT+25 ;MODULO TEN AND SAVE.
HRLM 2,0(17)
SKIPE 1
PUSHJ 17,WRINT+13
HLRZ 1,0(17)
ADDI 1,60
XCT WRINT+26 ;RESTORE & PRINT.
POPJ 17,0
RETX: POP 17,2
POPJ 17,0
0
0
WRINT+23
;;ENTRY RDSIX ↔ TITLE RDSIX
;;.INSERT LIBRARY.TMP
;;NSUBR RDSIX,-2(17),BRKTAB
; Read SIXBIT, where BRKTAB is address of 4 word bit table indicating what
; characters are terminators.
; If there are more than 6 characters, additional characters are ignored.
;
; Returns SIXBIT in 1
; Terminating character in 0.
;; ACCUMULATOR{T1,2}
RDSIX: PUSH 17,2 ;Save AC's we'll need
PUSH 17,3
MOVSI 3,440600 ;Pointer to where SIXBIT will go
SETZ 0,
LOOPX: XCT -4(17) ;Pick up a character
PUSH 17,1
IDIVI 1,=36
ADD 1,-4(17)
MOVE 1,(1)
LSH 1,(2)
JUMPL 1,RETZ ;1 means terminator
POP 17,1
CAIGE 1,"a"
SUBI 1,40
CAME 3,RDSIX+26 ;Check for more than 6 characters
IDPB 1,3 ;Pack into word
JRST LOOPX
RETZ: MOVE 1,0 ;Get SIXBIT to return
POP 17,0 ;Get back terminator
POP 17,3 ;Restore saved AC's
POP 17,2 ;Restore saved AC's
JRST POP2J.
600,,0
;;ENTRY WRSIX ↔ TITLE WRSIX
;;.INSERT LIBRARY.TMP
;;NSUBR WRSIX,SIX,-2(17)
; Convert sixbit word into character stream.
WRSIX: PUSH 17,0
MOVEI 0,6
PUSH 17,WRSIX+12
LOOPW: ILDB 1,(17)
ADDI 1,40
XCT -3(17)
SOJG LOOPW
POP 17,0
POP 17,0
JRST POP2J.
ANDCB 14,-3(17)
SWBRK: -1 ;<null> thru #
BYTE (29) -1 (7)0 ;$ thru G,
BYTE (19) 0 (6) -1 (11) 0 ;H thru k
BYTE (15) 0 (5) -1 ;l thru <bs>
SUBTTL Tables and Flags
PLIST: BLOCK LPLIST
PDLIOWD:IOWD LPLIST,PLIST
OSTK: BLOCK LOSTK
RQ1: BLOCK LRQ ;THE RUN QUEUE, CLOUMN ONE.
RQ2: BLOCK LRQ ;COLUMN TWO.
PATCH: BLOCK 100 ;LET'S HEAR IT FOR DEBUGGING!
;Symbol table pointers
BUCTBL: FOR I←0,BUCKNO-1,1 < CAT(SYM,→I)↔ >
STRBUC: 0 ;HEAD OF STRING TABLE
NUMBUC: EXP C ;HEAD OF NUMBER TABLE
OUTFIL: NULLDV ;Pointer to default output specification, initially undefined
INFILE: 0 ;NAME FOR READIN FILE
;A COPY OF ABOVE FOR RESET COMMAND
SVAREA: FOR I←0,BUCKNO-1,1 < CAT(SYM,→I)↔ >
0 ;FOR STRBUC
C ;FOR NUMBUC
NULLDV ;FOR POUTSP
IARR1: ;; HERE BEGINS AN AREA WHICH IS ZEROED DURING
;; INITIALIZATION OF EACH COMPILATION.
UOTBL: BLOCK LUOTBL
ACS:
RACS: BLOCK 20 ;R-TIME AC TABLE
IACS: BLOCK 20 ;I-TIME AC TABLE
; THE FOLLOWING FLAGS MUST BE PUSHED AND MAY NOT BE BITS
; THESE ARE INITED TO 0
IONLY: 0 ;FLAG TO GENERATE ONLY I-TIME CODE
BLEVEL: 0 ;BLOCK LEVEL
RSTATE: 0 ;USED TO SET R-TIME ATTRIBUTES OF STATEMENT LISTS
NOTAC0: 0 ;FLAG INDICATING NOT TO USE AC0
LOGFLG: 0 ;IF 0 THEN TREAT '<` AS A COMMENT
UGEXPF: 0 ;SET WHEN WE WANT A U.G. TO RETURN A VALUE
UOPTR: -1 ;COUNT OF U SYMBOLS
IARR2:
; THESE GET SET TO -1
DONEFX: -1 ;FIXUP FOR WHILE-UNTIL-FOR LOOPS
-1
EXITFX: -1 ;FIXUP FOR BLOCK EXITS
-1
RETFIX: -1 ;FIXUP FOR RETURN STATEMENTS (ALWAY I-TIME CODE)
IARR5:
; PBASE(INSXR) ;SO THAT P MAY BE AN ARRAY
XWD INSXR,PBASE ;FW strikes again! FAIL once accepted the above line
LPA ;SIZE OF P ARRAY
IARR4:
PBASE: BLOCK LPA
OUTA: 0 ;CHANNEL A OUTPUT SAMPLE ACCUMULATED HERE.
OUTB: 0 ;CHANNEL B.
OUTC: 0 ;CHANNEL C.
OUTD: 0 ;CHANNEL D.
IARR3:
VLOC: 0
ILOC: 0
RLOC: 0
;DEBUGGING STUFF
LSTWRD: BLOCK 3 ;LAST WORD OF CODE EMITTED
↓LSTLOA:0 ;LAST PLACE CODE WAS LOADED
NULLDV: ASCIZ// ;No device, used to indicate MUSCMP to explicitly ask for it
VAR
LIT
MUSEND: END GO